by Cyrus Austria Lacaba - LP City, Phil. (1 Submission)
Category: Internet/HTML
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 23rd January 2008
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Sending Mail using Microsoft Outlook
API Declarations
'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 = "[email protected];[email protected]"
' .BCCTo = "[email protected]"
' .CCTo = "[email protected]"
' .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$
VBcoders
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 protected]
'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 protected]
'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