Send Email from MS Access using VBA and VBScript - Tutorial¶

' To use the following codes, please download and install
' https://www.emailarchitect.net/webapp/download/easendmail.exe on your machine

Option Compare Database

Private WithEvents oSmtp As EASendMailObjLib.Mail
Private CurrentEmailIsFinished As Boolean
Private HasErrorWithEmail As Boolean
Private ErrorDescription As String
Private CancelSending As Boolean

Private Sub InitVariables()
    CurrentEmailIsFinished = True
    HasErrorWithEmail = False
    ErrorDescription = ""
    CancelSending = False
End Sub

Private Sub btnCancel_Click()
    btnFocus.SetFocus
    btnCancel.Enabled = False
    If Not (oSmtp Is Nothing) Then
        oSmtp.Terminate
        CancelSending = True
        CurrentEmailIsFinished = True
    End If
End Sub

Private Sub Form_Load()
    btnCancel.Enabled = False
    btnSend.Enabled = True
    btnFocus.TabStop = False
    btnFocus.Transparent = True
    InitVariables
End Sub

Private Sub btnSend_Click()
    btnFocus.SetFocus
    btnCancel.Enabled = True
    btnSend.Enabled = False

    SendMailFromAccess

    btnCancel.Enabled = False
    btnSend.Enabled = True
End Sub

Private Sub oSmtp_OnAuthenticated()
    SysCmd acSysCmdSetStatus, "Authenticated"
End Sub

Private Sub oSmtp_OnClosed()
    CurrentEmailIsFinished = True
End Sub

Private Sub oSmtp_OnConnected()
    SysCmd acSysCmdSetStatus, "Connected"
End Sub

Private Sub oSmtp_OnError(ByVal lError As Long, ByVal ErrDescription As String)
    HasErrorWithEmail = True
    CurrentEmailIsFinished = True
    ErrorDescription = ErrDescription
End Sub

Private Sub oSmtp_OnSending(ByVal lSent As Long, ByVal lTotal As Long)
    SysCmd acSysCmdSetStatus, "Sending " & lSent & "/" & lTotal & " ..."
End Sub

Public Sub SendMailFromAccess()

    Dim sender, Name, address, subject, bodyTemplate, body, bodyFormat
    bodyFormat = 0 'Text body format

    ' Please change sender address to yours
    sender = "test@emailarchitect.net"
    subject = "Test email from MS Access and VBA"

    ' Use a body template to build body text based on recipient's name
    bodyTemplate = "Dear {name}," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
        "This is a test email from MS Access using VBA, do not reply."

    Dim rs, sql
    Set rs = CreateObject("ADODB.Recordset")

    sql = Me.RecordSource
    If Me.FilterOn Then
        sql = sql & " WHERE " & Me.Filter
    End If

    rs.Open sql, CurrentProject.Connection
    rs.MoveFirst

    Dim emailSent
    emailSent = 0

    Do While Not rs.EOF
        Name = Trim(rs!Name)
        address = Trim(rs!Email)
        body = Replace(bodyTemplate, "{name}", Name)

        If Not SendMailTo(sender, Name, address, subject, body, bodyFormat) Then
            Exit Sub
        End If

        emailSent = emailSent + 1
        rs.MoveNext

    Loop

    SysCmd acSysCmdSetStatus, "Total " & emailSent & " email(s) sent."

End Sub

Function SendMailTo(sender, Name, address, subject, body, bodyFormat)

    Set oSmtp = New EASendMailObjLib.Mail
    oSmtp.LicenseCode = "TryIt"

    ' Please change server address, user, password to yours
    oSmtp.ServerAddr = "mail.emailarchitect.net"
    oSmtp.UserName = "test@emailarchitect.net"
    oSmtp.Password = "yourpassword"

    ' Set server port, if 25 port doesn't work, try to use 587 port
    oSmtp.ServerPort = 25

    ' Using TryTLS,
    ' If smtp server supports TLS, then TLS connection is used; otherwise, normal TCP connection is used.
    ' https://www.emailarchitect.net/easendmail/sdk/?ct=connecttype
    oSmtp.ConnectType = 4

    ' If your server is Exchange 2007 or later version, you can use EWS protocol.
    ' https://www.emailarchitect.net/easendmail/sdk/?ct=protocol
    ' Set Exchange Web Service Protocol - EWS - Exchange 2007/2010/2013/2016
    ' oSmtp.Protocol = 1

    oSmtp.FromAddr = sender
    oSmtp.AddRecipient Name, address, 0

    oSmtp.subject = subject
    oSmtp.bodyFormat = bodyFormat
    oSmtp.BodyText = body

    ' You can add attachment like this:
    ' Add attachment from local disk
    ' If oSmtp.AddAttachment("d:\test.jpg") <> 0 Then
        ' Application.StatusBar = "Failed to add attachment with error:" & oSmtp.GetLastErrDescription()
        ' SendMailTo = False
        ' Exit Function
    'End If

    SysCmd acSysCmdSetStatus, "Connecting " & oSmtp.ServerAddr & " ..."

    oSmtp.Asynchronous = 1
    InitVariables
    CurrentEmailIsFinished = False
    oSmtp.SendMail

    Do While Not CurrentEmailIsFinished
        ' Wait for the email sending, you can do other thing here
        DoEvents
    Loop

    If CancelSending Then
        SysCmd acSysCmdSetStatus, "Operation was terminated by user!"
        SendMailTo = False
    ElseIf HasErrorWithEmail Then
        SysCmd acSysCmdSetStatus, "Failed to send email to " & address & "; " & ErrorDescription
        SendMailTo = False
    Else
        SysCmd acSysCmdSetStatus, "Message to " & address & " has been submitted to server."
        SendMailTo = True
    End If

    Set oSmtp = Nothing
End Function

oSmtp.FromAddr = "Tester<test@adminsystem.com>"
oSmtp.FromAddr = "test@adminsystem.com"
oSmtp.FromAddr = "<test@adminsystem.com>"

' Using AddRecipientEx to add To, Cc and Bcc in VB 6.0/Visual Basic 6.0
' Multiple addresses are separated with (,)
' The syntax is like this: "test@adminsystem.com, test1@adminsystem.com"
oSmtp.AddRecipientEx "test1@adminsystem.com, test2@adminsystem.com", 0
oSmtp.AddRecipientEx "Test1<test@adminsystem.com>, Test2<test2@adminsystem.com>", 0

' You can also add carbon copy (CC) or blind carbon copy (BCC) in the email.
oSmtp.AddRecipientEx "CC recipient<cc@adminsystem.com>", 1
oSmtp.AddRecipientEx "Bcc recipient<bcc@adminsystem.com>", 2

' [VB, VBA - From, ReplyTo, Sender and Return-Path]
Dim oSmtp As New EASendMailObjLib.Mail
oSmtp.LicenseCode = "TryIt"
oSmtp.FromAddr = "from@adminsystem.com"
oSmtp.ReplyTo = "reply@adminsystem.com"
oSmtp.Sender = "sender@emailarchitect.net"
oSmtp.ReturnPath = "report@emailarchitect.net"

'[VBScript, ASP - From, ReplyTo, Sender and Return-Path]
Dim oSmtp
Set oSmtp = Server.CreateObject("EASendMailObj.Mail")
oSmtp.LicenseCode = "TryIt"
oSmtp.FromAddr = "from@adminsystem.com"
oSmtp.ReplyTo = "reply@adminsystem.com"
oSmtp.Sender = "sender@emailarchitect.net"
oSmtp.ReturnPath = "report@emailarchitect.net"

' If your smtp server requires TLS connection, please add this line
oSmtp.ConnectType = 1

oSmtp.LogFileName = "d:\smtp.txt"