Thursday, October 3, 2013

Excel VBA | Automate Sending eMails

Public Function Mail_Workbook_Outlook(ByRef RecptAddr As String, Optional ByRef Subject As String, Optional ByRef Body As String, Optional ByRef CC As String, Optional ByRef BCC As String, Optional ByRef AttachmentPath As String, Optional ByRef attachAWB As Boolean, Optional ByRef displayMail As Boolean)
    Dim OlApp As Object
    Dim OlMail As Object
   
    Set OlApp = CreateObject("Outlook.Application")
    Set OlMail = OlApp.CreateItem(0)
   
    On Error Resume Next
    With OlMail
        .To = RecptAddr
        .CC = CC
        .BCC = BCC
        .Subject = Subject
        .Body = Body
        Select Case attachAWB
            Case True
                .attachments.Add ActiveWorkbook.FullName
        End Select
        If AttachmentPath <> "" Then
            .attachments.Add (AttachmentPath)
        End If
       
        Select Case displayMail
            Case True
                .Display
            Case False
                .Send
            Case Else
                .Display
        End Select
    End With
    On Error GoTo 0
   
    Set OlMail = Nothing
    Set OlApp = Nothing
End Function

Public Function Mail_Workbook_SendMail(ByVal RecptAddr As String, Optional ByVal Subject As String)
   
    ActiveWorkbook.SendMail RecptAddr, Subject

End Function


Public Function gMailCDO(ByVal gmailUsername As String, ByVal gmailPassword As String, ByRef eMessage As String, ByRef RecptAddr As String, Optional ByRef eSubject As String, Optional ByRef CC As String, Optional ByRef BCC As String, Optional ByRef AttachmentFullPath As String, Optional ByRef smtpServer As String, Optional ByRef smtpPort As Integer)
Dim eMail As Object
Dim eConfig As Object

Dim Flds As Variant

Set eMail = CreateObject("CDO.Message")
Set eConfig = CreateObject("CDO.Configuration")

    If smtpServer = "" Then
        smtpServer = "smtp.gmail.com"
    End If
    If Not smtpPort Then
        smtpPort = 465
    End If

    eConfig.Load -1
    Set Flds = eConfig.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = gmailUsername
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = gmailPassword
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpServer
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpPort
        .Update
    End With
   
    With eMail
        Set .configuration = eConfig
        .To = RecptAddr
        .CC = CC
        .BCC = BCC
        .From = RecptAddr
        .Subject = eSubject
        .TextBody = eMessage
        If AttachmentFullPath <> "" Then
            .AddAttachment AttachmentFullPath
        End If
    End With
       
End Function

1 comment:

  1. Hi There,
    This is great stuff. I have a unique requirement though. I need so send out follow-up emails based on certain parameters. for e.g - if its been 13 days since a particular emai/step and also if a customer hasn't replied to me or completed a required step within that time. Could I request your help?

    Thank you.
    Reuben

    ReplyDelete