Consulting

Results 1 to 6 of 6

Thread: VBA to paste table into email

  1. #1
    VBAX Newbie
    Joined
    Apr 2019
    Posts
    3
    Location

    VBA to paste table into email

    So I have two sets of script that I am trying to get to work together. The select and copy script needs to remain as is because it only selects cells that display a value and this varies depending on how many employees there are in that range etc... The copy portion of what I am trying to do works fine. But I can't get it to paste into an email that generates with the second one that is "called" at the end of the copy script. The second one opens and email and puts some generic verbiage in it but I can't get the selection that was copied to paste in the body. However I can click in the email that is generated and "ctrl + v" and the selection will paste in there fine.

    Any ideas?

    Copy Script:

    Sub a()
    Dim LR As Long, cell As Range, rng As Range
    With Sheets("Manpower Output")
    LR = .Range("G" & Rows.Count).End(xlUp).Row
    For Each cell In .Range("A1:G500" & LR)
    If cell.Value <> "" Then
    If rng Is Nothing Then
    Set rng = cell
    Else
    Set rng = Union(rng, cell)
    End If
    End If
    Next cell
    rng.Select
    End With
    Selection.Copy
    Call EmailWithOutlook
    End Sub
    Open Email Script:

    Sub EmailWithOutlook()
    'Variable declaration
    Dim oApp As Object, oMail As Object, Pth As String
    'Create and show the outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
    'Uncomment the line below to hard code a recipient
    '.To = ""
    'Uncomment the line below to hard code a subject
    .Subject = "Subject Here"
    .Body = "All," & vbNewLine & _
    vbNewLine & _
    "Please see attached" & vbNewLine & _
    vbNewLine & _
    "Thanks,"
    .Display
    End With
    'Restore screen updating and release Outlook
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
    End Sub

  2. #2
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    421
    Location
    .
    Option Explicit
    
    
    Sub CopyRows()
    Dim i As Integer
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
        ws1.Range("A1:M42").Copy
        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")
    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
    VBAX Newbie
    Joined
    Apr 2019
    Posts
    3
    Location
    Thank you this works well enough.

    Follow up: How do I get the ".To" portion to populate with emails in a list from cells A1:A100 on another sheet?

  4. #4
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    421
    Location
    .
    Use this macro. The added lines of code are shown in bold red :


    Option Explicit
    
    
    Sub CopyRows()
    Dim i As Integer
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
        ws1.Range("A1:M42").Copy
        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
    Dim c As Range
    
    
    Set rng = Nothing
    ' Only send the visible cells in the selection.
    Set rng = Sheets("Sheet1").Range("A1:M42")
    If rng Is Nothing Then
        MsgBox "An unknown error has occurred. "
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    
    For Each c In Sheet2.Range("A1:A100")
        If c.Value <> "" Then
        
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = c.Value
                .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
            
        End If
    Next c
    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

  5. #5
    VBAX Newbie
    Joined
    Apr 2019
    Posts
    3
    Location
    Thanks!

  6. #6
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    421
    Location
    .
    You are welcome.

Posting Permissions

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