none
Pasting range into outlook as picture RRS feed

  • Question

  • I have this code that I found on the web a long time ago (thank you Ron de Bruin) and have been using in many projects. I now need to modify so that it pastes the range in the outlook email as a picture. I am not an expert at all I just have been modifying VBA code to fit my projects. There is a lot of samples on how to paste as a picture but I can't seem to make it work and still keep the functionality of what I currently have. The code I currently have works perfectly but pastes the data as a table in Outlook (the default).

    Sub Email_Options()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Signature As String
    
    Set rng = Nothing
    ' Only send the visible cells in the selection.
    
    Set rng = Sheets("Closing Costs").Range("B50:E73")
    
    
    If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
    End If
    
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
    .Display
    End With
    Signature = OutMail.HTMLBody
    StrBody = "Loan Options: "
    
    With OutMail
    .Subject = "Loan Options (loanDepot) "
    .HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & 
    StrBody & RangetoHTML(rng) & Signature
    .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)
    ' By Ron de Bruin.
    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 paste 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
    


    MEC

    Saturday, September 22, 2018 3:27 PM

All replies

  • Hi mecerrato,

    I tried your code and found some issues. However, I've updated it successfully. You can try this:

    Option Explicit
    
    Sub Email_Options()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Signature As String
    Dim StrBody As String
    
    Set rng = Nothing
    ' Only send the visible cells in the selection.
    
    Set rng = Sheets("Sheet1").Range("A1:B17") 'You need to modify the "Sheet1" and Range"A1:B17"
    
    
    If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
    End If
    
    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
    .Display
    End With
    Signature = OutMail.HTMLBody
    StrBody = "Loan Options: "
    
    With OutMail
    .Subject = "Loan Options (loanDepot) "
    .HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & _
    StrBody & RangetoHTML(rng) & Signature
    .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)
    ' By Ron de Bruin.
    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 paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    TempWB.Activate
    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
    
    

    Also, I commented the following code since it would be an error in my Excel 2016 environment.

    '.DrawingObjects.Visible = True
    '.DrawingObjects.Delete
    

    Regards,

    Simon


    MSDN Community Support Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread.

    Monday, September 24, 2018 9:14 AM
    Moderator
  • Hi mecerrato,

    Did you resolve your problem? if your issue is still exist then let us know about that, we will try to suggest you further to solve the issue.

    Regards,

    Simon


    MSDN Community Support Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread.

    Monday, October 8, 2018 5:18 AM
    Moderator