Skip to content

Instantly share code, notes, and snippets.

@rwjblue
Last active February 7, 2023 01:56
Show Gist options
  • Save rwjblue/4625562 to your computer and use it in GitHub Desktop.
Save rwjblue/4625562 to your computer and use it in GitHub Desktop.
Generate and Send an Email with CDO from VB6
' 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment