Sending Email From Excel using VBA

It is not difficult to add the ability to send email from your application. If all you want to do is send the workbook, with just a subject but no content, you can use ThisWorkbook.SendMail. However, if you want to include text in the body of the message or include additional files as attachments, you need some VBA code. The page describes a function called SendEmail that wraps up the details in a nice, VBA-friendly function

Function SendEMail(Subject As String, _
        FromAddress As String, _
        ToAddress As String, _
        MailBody As String, _
        SMTP_Server As String, _
        BodyFileName As String, _
        Optional Attachments As Variant) As Boolean

Where
Subject is the subject line of the email.

FromAddress is your email address.

ToAddress is the address to which the email will be sent. You can send a message to multiple recipients by separating the email addresses with semi-colons.

MailBody is the text that is to be the body of the message. If you leave this blank andBodyFileName names a text file, the body of the message will be all the text in the file named byBodyFileName. If both BodyFileName and MailBody are empty, the message is sent with no body.

SMTP_Server is the name of your outgoing mail server.

BodyFileName is the name of the text file that will be used as the body of the message. IfMailBody is not empty, this parameter is ignored and the file is not used as the body. If bothMailBody and BodyFileName are not empty, the contents of MailBody is used as the body andBodyFileName is ignored.

Attachments is a single file name or an array of file names to attach to the message. If there is an error attaching one of the files, processing continues with the rest of the files and the email will be sent.

The function returns True if successful or False if an error occurred.

The code requires a reference to Microsoft CDO for Windows 2000 Library. The typical file location of this file is C:\Windows\system32\cdosys.dll. The GUID of this component is {CD000000-8B95-11D1-82DB-00C04FB1625D}, with Major = 1 and Minor = 0.

*********************************************************************************

The Code

The code is shown below.

Function SendEMail(Subject As String, _
        FromAddress As String, _
        ToAddress As String, _
        MailBody As String, _
        SMTP_Server As String, _
        BodyFileName As String, _
        Optional Attachments As Variant = Empty) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SendEmail Function
' By Anoop Kumar V 
'
' This function sends an email to the specified user.
' Parameters:
'   Subject:        The subject of the email.
'   FromAddress:    The sender's email address
'   ToAddress:      The recipient's email address or addresses.
'   MailBody:       The body of the email.
'   SMTP_Server:    The SMTP-Server name for outgoing mail.
'   BodyFileName:   A text file containing the body of the email.
'   Attachments     A single file name or an array of file names to
'                   attach to the message. The files must exist.
' Return Value:
'   True if successful.
'   False if failure.
'
' Subject may not be an empty string.
' FromAddress must be a valid email address.
' ToAddress must be a valid email address. To send to multiple recipients,
' use a semi-colon to separate the individual addresses. If there is a
' failure in one address, processing terminates and messages are not
' send to the rest of the recipients.
' If MailBody is vbNullString and BodyFileName is an existing text file, the content
' of the file named by BodyFileName is put into the body of the email. If
' BodyFileName does not exist, the function returns False. The content of
' the message body is created by a line-by-line import from BodyFileName.
' If MailBody is not vbNullString, then BodyFileName is ignored and the body
' is not created from the file.
' SMTP_Server must be a valid accessable SMTP server name.
' If both MailBody and BodyFileName are vbNullString, the mail message is
' sent with no body content.
' Attachments can be either a single file name as a String or an array of
' file names. If an attachment file does not exist, it is skipped but
' does not cause the procedure to terminate.
'
' If you want to send ThisWorkbook as an attachment to the message, use code
' like the following:
'    ThisWorkbook.Save
'    ThisWorkbook.ChangeFileAccess xlReadOnly
'    B = SendEmail( _
'        ... parameters ...
'        Attachments:=ThisWorkbook.FullName)
'    ThisWorkbook.ChangeFileAccess xlReadWrite
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Required References:
' --------------------
'   Microsoft CDO for Windows 2000 Library
'       Typical File Location: C:\Windows\system32\cdosys.dll
'       GUID: {CD000000-8B95-11D1-82DB-00C04FB1625D}
'       Major: 1    Minor: 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim MailMessage As CDO.Message
Dim N As Long
Dim FNum As Integer
Dim S As String
Dim Body As String
Dim Recips() As String
Dim Recip As String
Dim NRecip As Long

' ensure required parameters are present and valid.
If Len(Trim(Subject)) = 0 Then
    SendEMail = False
    Exit Function
End If

If Len(Trim(FromAddress)) = 0 Then
    SendEMail = False
    Exit Function
End If

If Len(Trim(SMTP_Server)) = 0 Then
    SendEMail = False
    Exit Function
End If

' Clean up the addresses
Recip = Replace(ToAddress, Space(1), vbNullString)
If Right(Recip, 1) = ";" Then
    Recip = Left(Recip, Len(Recip) - 1)
End If
Recips = Split(Recip, ";")


For NRecip = LBound(Recips) To UBound(Recips)
    On Error Resume Next
    ' Create a CDO Message object.
    Set MailMessage = CreateObject("CDO.Message")
    If Err.Number <> 0 Then
        SendEMail = False
        Exit Function
    End If
    Err.Clear
    On Error GoTo 0
    With MailMessage
        .Subject = Subject
        .From = FromAddress
        .To = Recips(NRecip)
        If MailBody <> vbNullString Then
            .TextBody = MailBody
        Else
            If BodyFileName <> vbNullString Then
                If Dir(BodyFileName, vbNormal) <> vbNullString Then
                    ' import the text of the body from file BodyFileName
                    FNum = FreeFile
                    S = vbNullString
                    Body = vbNullString
                    Open BodyFileName For Input Access Read As #FNum
                    Do Until EOF(FNum)
                        Line Input #FNum, S
                        Body = Body & vbNewLine & S
                    Loop
                    Close #FNum
                    .TextBody = Body
                Else
                    ' BodyFileName not found.
                    SendEMail = False
                    Exit Function
                End If
            End If ' MailBody and BodyFileName are both vbNullString.
        End If
        
        If IsArray(Attachments) = True Then
            ' attach all the files in the array.
            For N = LBound(Attachments) To UBound(Attachments)
                ' ensure the attachment file exists and attach it.
                If Attachments(N) <> vbNullString Then
                    If Dir(Attachments(N), vbNormal) <> vbNullString Then
                        .AddAttachment Attachments(N)
                    End If
                End If
            Next N
        Else
            ' ensure the file exists and if so, attach it to the message.
            If Attachments <> vbNullString Then
                If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
                    .AddAttachment Attachments
                End If
            End If
        End If
        With .Configuration.Fields
            ' set up the SMTP configuration
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
        
        On Error Resume Next
        Err.Clear
        ' Send the message
        .Send
        If Err.Number = 0 Then
            SendEMail = True
        Else
            SendEMail = False
            Exit Function
        End If
    End With
Next NRecip
SendEMail = True
End Function

If you want to attach the workbook that contains the code, you need to make the file read-only when you send it and then change access back to read-write. For example,

ThisWorkbook.Save
ThisWorkbook.ChangeFileAccess xlReadOnly
B = SendEmail( _
    ... parameters ...
    Attachments:=ThisWorkbook.FullName)
ThisWorkbook.ChangeFileAccess xlReadWrite

Please let me know your doubts....