• Home
 · 
• Internet/HTML
 · 
• Sending Mail using Microsoft Outlook

Sending Mail using Microsoft Outlook

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$




Rate Sending Mail using Microsoft Outlook

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

    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