Friday, January 3, 2014

Progmatically Automate Sending eMails via Excel VBA and gMail CDO

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

No comments:

Post a Comment