تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
ارسال ايميل باستخدام Microsoft Outlook
#1
كاتب الموضوع : Norhan Adel

Declaration

كود :
'This is a Class Module for Sending Mail using Microsoft Outlook.
'Below are the modifications:
'1. Includes Multiple Email Address Validation and Entry.
'2. Validates multiple "." before @ sign and multiple Extension after @ sign
'3. Validates Domain name

'How to work:
'IniFile must contain the List of Domain Name and Extensions
'GetMessage is a user defined function that retrieves the contents of the Ini file. It uses GetPrivateProfileString API Function.


'Private Sub cmdMail_Click()
'Dim arrDomain() As String
'Dim arrExt() As String
'Dim cMail As New clsMail

'arrDomain() = Split(GetMessage("Mail", "Domain Name", App.Path & "\Ini files\Mail.ini"), ",")
'arrExt() = Split(GetMessage("Mail", "Domain Extension", App.Path & "\Ini 'files\Mail.ini"), ",")
'
' With cMail
' .DomainList = Join(arrDomain, ",")
' .MailExtension = Join(arrExt, "")
' .SendTo = "cyrus.biohazard@yahoo.com.ph;jc022203@hotmail.com"
' .BCCTo = "cyrus.biohazard@yahoo.com.ph"
' .CCTo = "cyrus.biohazard@yahoo.com.ph"
' .AttachmentList = "c:\YServer.txt,c:\CKINFO.txt"
' .MailSubject = "Sample"
' .MailBody = "Body"
' .SendMail
' End With
'
'End Sub



Private strDomain$, _
strDomainExt$, _
strToList$, _
strCCTo$, _
strBCCTo$, _
strAList$, _
ArrofRec() As String, _
ArrofAtt() As String, _
strSubject$, _
strBody$, _
EMsg$
Code

كود :
Public Property Get SendTo() As String
SendTo = strToList$
End Property
Public Property Let SendTo(strValue As String)
strToList$ = strValue
End Property
Public Property Get CCTo() As String
CCTo = strCCTo$
End Property
Public Property Let CCTo(strValue As String)
strCCTo$ = strValue
End Property
Public Property Get BCCTo() As String
BCCTo = strBCCTo$
End Property
Public Property Let BCCTo(strValue As String)
strBCCTo$ = strValue
End Property
Public Property Get AttachmentList() As String
AttachmentList = strAList$
End Property
Public Property Let AttachmentList(strValue As String)
strAList$ = strValue
End Property
Public Property Get MailSubject() As String
MailSubject = strSubject$
End Property
Public Property Let MailSubject(strValue As String)
strSubject$ = strValue
End Property
Public Property Get MailBody() As String
MailBody = strBody$
End Property
Public Property Let MailBody(strValue As String)
strBody$ = strValue
End Property
Public Property Get DomainList() As String
DomainList = strDomain$
End Property
Public Property Let DomainList(strValue As String)
strDomain$ = strValue
End Property
Public Property Get MailExtension() As String
MailExtension = strDomainExt$
End Property
Public Property Let MailExtension(strValue As String)
strDomainExt$ = strValue
End Property
Public Property Get MailErrMsg() As String
MailErrMsg = EMsg$
End Property
Private Function ValidateEAdd(ByVal strEmail As String) As Boolean
Dim strTmp As String, n As Long
EMsg = "" 'reset on open for good form
ValidateEAdd = True 'Assume true on init

If strEmail = "" Then
ValidateEAdd = False
EMsg = EMsg & "Not a valid email address!"

ElseIf InStr(1, strEmail, "@") = 0 Then
ValidateEAdd = False
EMsg = EMsg & "Email address does not contain an @ sign."

ElseIf InStr(1, strEmail, "@") = 1 Then
ValidateEAdd = False
EMsg = EMsg & "@ sign can not be the first character in email address!"

ElseIf InStr(1, strEmail, "@") = Len(strEmail) Then
ValidateEAdd = False
EMsg = EMsg & "@sign can not be the last character in email address!"

'Extension Validation
ElseIf EXTisOK(strEmail) = False Then
ValidateEAdd = False
EMsg = EMsg & "Email address is not carrying a valid extension!"

'Domain Validation
ElseIf DMisOK(strEmail) = False Then
ValidateEAdd = False
EMsg = EMsg & "Email address is not carrying a valid domain name!"

'Multiple @ Validation
ElseIf NoMultiATVAl(strEmail) = False Then
ValidateEAdd = False 'found more than one @ sign
EMsg = EMsg & "More than 1 @ sign in your email address"

ElseIf Len(strEmail) < 6 Then
ValidateEAdd = False
EMsg = EMsg & "Email address is shorter than 6 characters which is impossible."
End If


End Function
Private Function NoMultiATVAl(sEAdd As String) As Boolean
Dim n%, _
sTempEAdd$

n = 0
NoMultiATVAl = True
sTempEAdd = sEAdd

Do While InStr(1, sTempEAdd, "@") <> 0
n = n + 1
sTempEAdd = Right(sTempEAdd, Len(sTempEAdd) - InStr(1, sTempEAdd, "@"))
DoEvents
Loop

If n > 1 Then
NoMultiATVAl = False 'found more than one @ sign
End If

End Function
Private Function EXTisOK(sEAdd As String) As Boolean
'sEAdd must be a complete email address
'To be corrected for the mail: [EMAIL="cyrus.biohazard@yahoo.com.ph"]cyrus.biohazard@yahoo.com.ph[/EMAIL]
'Fixed the error of multiple extension after @ sign and multilple "."
'before the @ sign.
Dim EXT As String, _
MExt() As String, _
EXTv As String, _
EXTtemp As String, _
ictr%

EXTisOK = False

EXTtemp = Mid(sEAdd, InStr(1, sEAdd, "@"))
EXTtemp = Mid(EXTtemp, InStr(1, EXTtemp, "."))
MExt = Split(EXTtemp, ".")

EXT = UCase(MailExtension) 'just to avoid errors

For ictr% = 1 To UBound(MExt)
EXTv = UCase("." & MExt(ictr%)) 'just to avoid errors
If InStr(1, EXT, EXTv) <> 0 Then
EXTisOK = True
Else
EXTisOK = False
Exit For
End If
Next

End Function
Private Function DMisOK(sDM As String) As Boolean
'sDM must be a complete email address
'To be corrected for the mail: [EMAIL="cyrus.biohazard@yahoo.com.ph"]cyrus.biohazard@yahoo.com.ph[/EMAIL]
'Fixed the error of multiple "." after @ sign
Dim DM As String, _
dmTemp As String

DMisOK = False
dmTemp = Right(sDM, Len(sDM) - InStr(1, sDM, "@"))
dmTemp = Left(dmTemp, InStr(1, dmTemp, ".") - 1)
dmTemp = UCase(dmTemp)
DM = UCase(DomainList)
If InStr(1, DM, dmTemp) <> 0 Then DMisOK = True

End Function
Public Sub SendMail()
Dim objOutlook As Outlook.Application
Dim objSession As Outlook.Namespace
Dim objMessage As Outlook.MailItem 'Object
Dim objRecipient As Object

ArrofRec = Split(SendTo, ";")
ArrofAtt = Split(AttachmentList, ",")

Set objOutlook = CreateObject("Outlook.Application")
Set objSession = objOutlook.GetNamespace("MAPI")
Set objMessage = objOutlook.CreateItem(olMailItem)

'Set objRecipient = objSession.CreateRecipient(strTo)

objSession.Logon

'Must fit to multiple recipient
For isendto% = 0 To UBound(ArrofRec)
If ValidateEAdd(ArrofRec(isendto%)) = True Then
Set objRecipient = objSession.CreateRecipient(ArrofRec(isendto%))
objMessage.Recipients.Add (objRecipient)
Set objRecipient = Nothing
End If
Next
Debug.Print objMessage.Recipients.Count
objMessage.BCC = BCCTo
objMessage.CC = CCTo
objMessage.Subject = MailSubject
objMessage.Body = MailBody

'Must fit to multiple attachment
For iattachment% = 0 To UBound(ArrofAtt)
objMessage.Attachments.Add (ArrofAtt(iattachment%))
Next
Debug.Print objMessage.Attachments.Count
objMessage.Send
'objMessage.Display
MsgBox "Message sent successfully!"
objSession.Logoff

End Sub
}}}
تم الشكر بواسطة:



التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم