Excel VBA Send Emails from Excel Through Outlook

Set Reference to Microsoft Office Library

We must send emails from Outlook. Since Outlook is an external object, we first need object reference to ‘Microsoft Outlook 16.0 Object Library.’

1.     In VBA, Go to Tools > References.

You see the object reference library. In this window, we should reference ‘Microsoft Outlook 16.0 Object Library.’

Sub Send_Outlook_Email()

Dim App As Outlook.Application
Dim Source As String
Set App = New Outlook.Application

Dim EmailItem As Outlook.MailItem
Set EmailItem = App.CreateItem(olMailItem)

EmailItem.To = "Example@gmail.com"
EmailItem.CC = "Example@gmail.com"
EmailItem.BCC = "Example@gmail.com"
EmailItem.Subject = "Test Email From MS Excel VBA."
EmailItem.HTMLBody = "Hi," & vbNewLine & vbNewLine & "This is my first email from Excel" & _
vbNewLine & vbNewLine & _
"Regards," & vbNewLine & _
"VBA Coder"
Source = ThisWorkbook.FullName
EmailItem.Attachments.Add Source

EmailItem.Send

End Sub

Function Sent_Active_Workbook(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
   On Error Resume Next
   Dim appOutlook As Object
   Dim mItem As Object
'create a new instance of Outlook
   Set appOutlook = CreateObject("Outlook.Application")
   Set mItem = appOutlook .CreateItem(0)
   With mItem 
     .To = strTo
     .CC = ""
     .Subject = strSubject
     .Body = strBody
     .Attachments.Add ActiveWorkbook.FullName
'use send to send immediately or display to show on the screen
    .Display 'or .Send
   End With
'clean up objects
  Set mItem = Nothing
  Set appOutlook = Nothing
End Function

Sub Send_Email()
   Dim strTo As String
   Dim strSubject As String
   Dim strBody As String
'populate variables
   strTo = "Example@gmail.com"
   strSubject = "Please find Example file attached"
   strBody = "body of the email"
"call the function to send the email"
   If Sent_Active_Workbook(strTo, strSubject, , strBody) = true then
      Msgbox "Email creation Success"
   Else
      Msgbox "Email creation failed!"
   End if
End Sub

Sending a Single Sheet from the Active Workbook

Function ActiveWorksheet(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
   On Error GoTo eh
'declare variables to hold the objects required
   Dim wbDestination As Workbook
   Dim strDestName As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim OutApp As Object
   Dim OutMail As Object
   Dim strTempName As String
   Dim strTempPath As String
'first create destination workbook
   Set wbDestination = Workbooks.Add
   strDestName = wbDestination.Name
'set the source workbook and sheet
   Set wbSource = ActiveWorkbook
   Set wsSource = wbSource.ActiveSheet
'copy the activesheet to the new workbook
   wsSource.Copy After:=Workbooks(strDestName).Sheets(1)
'save with a temp name
   strTempPath = Environ$("temp") & "\"
   strTempName = "List obtained from " & wbSource.Name & ".xlsx"
   With wbDestination
      .SaveAs strTempPath & strTempName
'now email the destination workbook
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
         .To = strTo
         .Subject = strSubject
         .Body = strBody
         .Attachments.Add wbDestination.FullName
'use send to send immediately or display to show on the screen
         .Display 'or .Display
      End With
      .Close False
  End With
'delete temp workbook that you have attached to your mail
   Kill strTempPath & strTempName
'clean up the objects to release the memory
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsSource = Nothing
   Set OutMail = Nothing
   Set OutApp = Nothing
Exit Function
eh:
   MsgBox Err.Description
End Function

run code

Sub SheetMail()
   Dim strTo As String
   Dim strSubject As String
   Dim strBody As String
   strTo = "jon.smith@gmail.com"
   strSubject = "Please find finance file attached"
   strBody = "some text goes here for the body of the email"
   If ActiveWorksheet(strTo, strSubject, , strBody) = True Then
      MsgBox "Email creation Success"
   Else
      MsgBox "Email creation failed!"
   End If
End Sub

MSEXCELVBA