Post shape from spreadhseet into correct position of html email created in vba

[alibini]

Hi, I am trying to create an email in outlook using VBA.
In the email i want to include text and a formatted table from the spreadhseet.
In addition i want to add an image/shape to the BOTTOM of the email, but I can't seem to get it to land there.

Here is the code i have managed to put together.

Any help much appreciated. I have spent many hours trying to figure it with no luck.

THANKS

Sub emailer()

 Set oOlApp = CreateObject("Outlook.Application")

 Set oOlMItem = oOlApp.CreateItem(olMailItem)
 Set oWB = ActiveWorkbook
 Set oWS = ActiveWorkbook.Worksheets("notes")


 With oOlMItem

  .Display

  .To = "email@email.com"
  .Subject = "Subject"
  .HTMLBody = "<H3><B>Dear Customer </B></H3>" & RangetoHTML(Sheets("Sheet1").Range("A1:C3").SpecialCells(xlCellTypeVisible))
  Set oOlInsp = .GetInspector
  Set oWdDoc = oOlInsp.WordEditor ' get Word Document from the MailBody

  Set oWdContent = oWdDoc.Content
  oWdContent.InsertParagraphBefore
  Set oWdRng = oWdDoc.Paragraphs(1).Range
  'oWdRng.InsertBefore "This is a test <"
  oWdRng.InsertParagraphAfter
  oWdRng.InsertParagraphAfter

 Set oPic = oWS.Shapes("Picture 3")
 oPic.CopyPicture ' oPic is now in Clipboard

  Set oWdRng = oWdDoc.Paragraphs(3).Range
  oWdRng.Paste ' paste from oPic Clipboard

  olFormatHTML = 2
  .BodyFormat = olFormatHTML ' change to HTML

 End With

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 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

 

[Domenic]

Try the following code. Note, it uses late binding, so there's no need for a reference to Outlook library.

Sub emailer()

    Dim oOlApp As Object
    Set oOlApp = CreateObject("Outlook.Application")
    
    Dim oOlMItem As Object
    Set oOlMItem = oOlApp.CreateItem(0) 'olMailItem
    
    Dim oWB As Workbook
    Set oWB = ActiveWorkbook
    
    Dim oWS As Worksheet
    Set oWS = oWB.Worksheets("notes")
    
    Dim oPic As Shape
    Set oPic = oWS.Shapes("Picture 3")
    
    With oOlMItem
        .Display
        .To = "email@email.com"
        .Subject = "Subject"
        .HTMLBody = "<H3><B>Dear Customer </B></H3>" & RangetoHTML(Sheets("Sheet1").Range("A1:C3").SpecialCells(xlCellTypeVisible))
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            oPic.CopyPicture ' oPic is now in Clipboard
            .Application.Selection.Paste
        End With
    End With
        
End Sub

Hope this helps!

 

[alibini]

Try the following code. Note, it uses late binding, so there's no need for a reference to Outlook library.

Sub emailer()

    Dim oOlApp As Object
    Set oOlApp = CreateObject("Outlook.Application")
   
    Dim oOlMItem As Object
    Set oOlMItem = oOlApp.CreateItem(0) 'olMailItem
   
    Dim oWB As Workbook
    Set oWB = ActiveWorkbook
   
    Dim oWS As Worksheet
    Set oWS = oWB.Worksheets("notes")
   
    Dim oPic As Shape
    Set oPic = oWS.Shapes("Picture 3")
   
    With oOlMItem
        .Display
        .To = "email@email.com"
        .Subject = "Subject"
        .HTMLBody = "<H3><B>Dear Customer </B></H3>" & RangetoHTML(Sheets("Sheet1").Range("A1:C3").SpecialCells(xlCellTypeVisible))
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            oPic.CopyPicture ' oPic is now in Clipboard
            .Application.Selection.Paste
        End With
    End With
       
End Sub

Hope this helps!

Thank you so much Domenic. That did the trick.
My goal was to create the email and save without ever having to see it so I can send it at a later time. Ie not using .display.
I did notice when using .save as without .display it did not save the message with the image.
I overcame by keeping the .display and adding .close 1 at the end.

Thanks again. Much appreciated.

 

[alibini]

Hi, follow up question to this solution please.

Is it possible to achieve in the body of the email:

HTML Text 1
Pasted image
HTML Text 2

Ie sandwich and image between two blocks of html pulled from cells in the spreadsheet.

Thanks!

 

[Domenic]

Try something like this...

    With oOlMItem
        .Display
        .To = "email@email.com"
        .Subject = "Subject"
        .HTMLBody = "<H3><B>Dear Customer </B></H3>" & RangetoHTML(Sheets("Sheet1").Range("A1:C3").SpecialCells(xlCellTypeVisible))
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            oPic.CopyPicture ' oPic is now in Clipboard
            .Application.Selection.Paste
        End With
        .HTMLBody = .HTMLBody & "<p>Your text here...</p>"
    End With

 

[alibini]

Try something like this...

    With oOlMItem
        .Display
        .To = "email@email.com"
        .Subject = "Subject"
        .HTMLBody = "<H3><B>Dear Customer </B></H3>" & RangetoHTML(Sheets("Sheet1").Range("A1:C3").SpecialCells(xlCellTypeVisible))
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            oPic.CopyPicture ' oPic is now in Clipboard
            .Application.Selection.Paste
        End With
        .HTMLBody = .HTMLBody & "<p>Your text here...</p>"
    End With

Thanks Domenic...... how often the solutions are the simple ones! Appreciate it.

 

[Domenic]

You're very welcome, cheers!