Stop searching. Start learning and developing your excel skills.
Macro
VBA
Formula
Function
Shortcut
Tricks

» » VBA to Mail from Excel with Outlook

VBA to Mail from Excel with Outlook

December 19, 2019 |
I have a worksheet with data from column A until column V. The data starts from row 3. I need to filter a column (column 21) with the data = "Pending" and send the data to selected recipients via email. If via manual, I will need to do the following:-

  1. Select the header which starting from row 3 until the last row
  2. Select visible cells only
  3. Copy the header and filtered range (visible cells)
  4. Go to MS Outlook
  5. Create New Email
    • Subject: Please Enter Email Subject!
    • To: xxx@gmail.com (1 people)
    • To: aaa@gmail.com, bbb@gmail.com, ccc@gmail.com (many people)
    • In the body of the email
      • Paste #3 above
      • Find and attach the excel file

With macro, below are the codes.

Public Sub SendEmail()

Application.DisplayAlerts = False

Dim objOutlook As Object
Dim objMail As Object
Dim i As Long
Dim rngA as Range
Dim rngB as Range
Dim rng as Range

i = Cells(Rows.Count, "A").End(xlUp).Row

ActiveSheet.Range("$A$4:$V$" & i).AutoFilter Field:=21, Criteria1:="Pending"
    Range("A4").Select
    Set rngA = ActiveSheet.Range("A3:V3") ''' This is header
    Set rngB = ActiveSheet.AutoFilter.Range ''' This is filtered range
    Set rng = Application.Union(rngA, rngB) ''' Combine header and filtered range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

            With objMail
            .Subject = "Please Enter Email Subject!"
            ''.To = "xxx@gmail.com"
            .To = "aaa@gmail.com;bbb@gmail.com;ccc@gmail.com"
            .HTMLBody = RangetoHTML(rng)
            .Attachments.Add ActiveWorkbook.FullName ''''' To attach current active workbook in email
            .Send
            End With
    Set objOutlook = Nothing
    Set objMail = Nothing
''' MsgBox "Done!" -- if needed
End Sub

Function RangetoHTML(rng As Range)
Application.DisplayAlerts = False
    Dim fso As Object ''' fso = File System Object
    Dim ts As Object ''' ts = TextStream
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim r As Long
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial xlPasteColumnWidths
            .Cells(1).PasteSpecial
            Application.CutCopyMode = False
       
            On Error Resume Next
       
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
       
            On Error GoTo 0
       
        End With

        With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, Sheet:=TempWB.Sheets(1).Name, Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)

        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

        TempWB.Close savechanges:=False

        Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function 

No comments:

Post a Comment