Consulting

Results 1 to 3 of 3

Thread: Issue VBA Copying/Displaying Table in Email Body

  1. #1
    VBAX Newbie
    Joined
    Jan 2020
    Posts
    1
    Location

    Issue VBA Copying/Displaying Table in Email Body

    Hi everyone,

    I have a very limited VBA knowledge and have been struggling with the following;

    Everyday I'm sending different data by email and found a way thanks to VBA to automate the process, when I get to the "creation email step", I have some issues apparently because of the format (not in HTML), displaying the email addresses and text in the body is fine as it is all linked to specific cells however if I want to display a table (within a specific range) it does not work

    My current code is the following;

    Sub George()
    Dim a As Integer
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngCc As Range
    Dim rngSubject As Range
    Dim rngBody As Range
    Dim rngAttach As Range

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

    a = ActiveCell.Row

    With ActiveSheet
    Set rngTo = .Cells(22, "B")
    Set rngCc = .Cells(24, "B")
    Set rngSubject = .Cells(26, "B")
    Set rngBody = .Range("B28")
    'Set rngAttach = .Range("B4")
    End With

    With objMail
    .To = rngTo.Value
    .CC = rngCc.Value
    .Subject = rngSubject.Value
    .Body = rngBody.Value
    '.Attachments.Add rngAttach.Value
    .Display 'Instead of .Display, you can use .Send to send the email _
    or .Save to save a copy in the drafts folder
    End With

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing
    Set rngAttach = Nothing
    End Sub
    To recap my query is: "how to display a specific range as an email body from excel ?"

    Apologies if I'm in the wrong section of the forum or if it has already been discussed, I tried to solve this by visiting other places and reading people with the same issue but couldn't solve it

    Thank you very much
    Regards

    DidierIV

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Option Explicit
    
    
    Sub CopyRows()
    Dim i As Integer
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
        ws1.Range("A1:M42").Copy '<---------------------------------------------adjust range here
        Mail_Selection_Range_Outlook_Body
    End Sub
    
    
    Sub Mail_Selection_Range_Outlook_Body()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lEndRow
    Dim Value As String
    Set rng = Nothing
    ' Only send the visible cells in the selection.
    Set rng = Sheets("Sheet1").Range("A1:M42") '<---------------------------------------------adjust range here
    If rng Is Nothing Then
        MsgBox "An unknown error has occurred. "
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "Your email address here in quotes"
        .CC = ""
        .BCC = ""
        .Subject = "Your Subject Here"
    
    
        .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Text below Excel cells.</p>"
        
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        '.Send
        .Display
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    End Sub
    Function RangetoHTML(rng As Range)
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
        'Publish the sheet to a htm file
        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
        'Read all data from the htm file into RangetoHTML
        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=")
        'Close TempWB
        TempWB.Close savechanges:=False
        'Delete the htm file we used in this function
        Kill TempFile
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function

  3. #3
    You can access the body of the message directly as if it was a Word document (which as Outlook uses elements of Word as editor, it effectively is) thus to insert a selection of the workbook -

    Option Explicit
    
    Sub SendWorkBook()
    'Graham Mayor - http://www.gmayor.com - Last updated - 26 Nov 2017
    'This macro requires the code from
    'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to open Outlook
    
    Dim oOutlookApp As Object
    Dim oItem As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim xlRng As Range
    Dim rngTo As Range
    Dim rngCc As Range
    Dim rngSubject As Range
    
        With ActiveSheet
            Set rngTo = .Cells(22, "B")
            Set rngCc = .Cells(24, "B")
            Set rngSubject = .Cells(26, "B")
            'Set rngBody = .Range("B28")
            'Set rngAttach = .Range("B4")
        End With
    
        Set xlRng = Range("A1:G20")    'The range to be copied
        xlRng.Copy    'Copy it
        Set oOutlookApp = OutlookApp()    'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
        'to open Outlook, or it will not work correctly
        'Create a new mailitem
        Set oItem = oOutlookApp.CreateItem(0)
        With oItem
            .BodyFormat = 2    'html
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor    'access the message body for editing
            Set oRng = wdDoc.Range
            oRng.Collapse 1    'set a range to the start of the message
            oRng.Text = "This is the message body before the Excel range:" & vbCr & vbCr
            'Collapse the range to its end
            oRng.Collapse 0
            oRng.Text = vbCr & "This is the text after the Excel range."
            'The range will be followed by the signature associated with the mail account
            'collapse the range to its start
            oRng.Collapse 1
            'paste the excel range in the message
            oRng.Paste
            'Address the message
            .To = rngTo.value
            .CC = rngCc.value
            'Give it a title
            .Subject = rngSubject.value
            'attach the workbook
            .Attachments.Add ActiveWorkbook.FullName
            'display the message - this line is required even if you then add the command to send the message
            .Display
        End With
    
        'Clean up
        Set oItem = Nothing
        Set oOutlookApp = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set xlRng = Nothing
        Set rngTo = Nothing
        Set rngCc = Nothing
        Set rngSubject = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •