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

Showing posts with label Excel To Outlook. Show all posts
Showing posts with label Excel To Outlook. Show all posts
Browse » Home » Posts filed under Excel To 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