Generate and Send an Email with CDO from VB6

email.vb

' From http://www.vbknowledgebase.com/?Id=21&Desc=Send-Email(E-Mail)-from-VB6-using-CDO

'****************************************************************
'*  Purpose :   To Send eMail
'*
'*  Inputs  :   strRecipient(String)    Recipient comma seperated
'*              strSubject(String)      Subject 
'*              strBody                  Body
'*              colAttachments          Collection of attachments
'*                                      file paths.
'*
'*  Returns :   Boolean about the sent status
'****************************************************************
Public Function SendEmail(ByVal strSender As String, _
                        ByVal strRecipient As String, _
                        ByVal strSubject As String, _
                        ByVal strBody As String, _
                        Optional ByVal strCc As String, _
                        Optional ByVal strBcc As String, _
                        Optional ByVal colAttachments As Collection _
                         ) As Boolean
    Dim cdoMsg As New CDO.Message
    Dim cdoConf As New CDO.Configuration
    Dim schema As String
    Dim Flds
    Dim attachment
    Dim strHTML
    
    On Error GoTo ErrTrap
    Const cdoSendUsingPort = 2
    
    'Set cdoMsg =  CreateObject("CDO.Message")
    'Set cdoConf = CreateObject("CDO.Configuration")
    
    Set Flds = cdoConf.Fields
        
    schema = "http://schemas.microsoft.com/cdo/configuration/"

    With Flds
        .Item(schema & "sendusing") = 2
        .Item(schema & "smtpserver") = "smtp.gmail.com" 
        .Item(schema & "smtpserverport") = 465
        .Item(schema & "smtpauthenticate") = 1
        .Item(schema & "sendusername") = "youremail@gmail.com"
        .Item(schema & "sendpassword") =  "yourpassword"
        .Item(schema & "smtpusessl") = 1
        .Update
    End With
    
    ' Apply the settings to the message.
    With cdoMsg
        Set .Configuration = cdoConf
        .To = strRecipient
        .From = strSender
        .Subject = strSubject
        .TextBody = strBody
        If Not colAttachments Is Nothing Then
            For Each attachment In colAttachments
                .AddAttachment attachment
            Next
        End If
        If strCc <> "" Then .CC = strCc
        If strBcc <> "" Then .BCC = strBcc
        .Send
    End With
    
    Set cdoMsg = Nothing
    Set cdoConf = Nothing
    Set Flds = Nothing
        
    SendEmail = True
    Exit Function
ErrTrap:
Err.Raise Err.Number, "", "Error from Functions.SendEmail" & Err.Description
    SendEmail = False
End Function