VBA: Including Multiple Excel Ranges as Pictures in Outlook Message (Greeting, Message, Images, End Message, and Signature)

[ashdaly5]

I am trying to use joh2239509's VBA Add Images into Email Body, which provide the images I want (total of 20 images). However when I try to .HTMLbody into the body of the email, the images come first, then the message and signature.I am trying to add a greeting, then message, then the 20 images, then end message with signature. I have tried to use a combination of Joh's code and Ron de Bruin's code but I have been unsuccessful. I don't want to use Ron's coding because the images that is pasted into outlook is blurry and does not look as clean as nor can I figure out how to insert more images into the email. The 20 images are necessary since copy and pasting a large range into outlook as a picture, the image size is reduced. Even resizing the image, the image do not look presentable and sloppy when trying to copy larger ranges. With these 20 ranges, the images are the same size when the message is sent and easily readable to the recipient.

I know in the .HMTLBody you can't add a call/run a function/sub. Any suggestions on how to code this correctly?

_________

Sub EmailBody()
    Dim Sht As Excel.Worksheet
        Set Sht = ActiveWorkbook.Sheets("Dashboard")
    Dim olApp As Object
        Set olApp = CreateObject("Outlook.Application")
    Dim Email As Object
        Set Email = olApp.CreateItem(0)
    Dim wdDoc As Word.Document
        Set wdDoc = Email.GetInspector.WordEditor
    Dim asofDate As String
        asofDate = Worksheets("dashboard").range("L6")
    Dim StartMsg As Variant
        StartMsg = "Greetings," & "<br><br>" & "Please find attached the report as of " & asofDate & ". <br><br>"
    Dim EndMsg As Variant
        EndMsg = "Regards," & Email.HTMLBody
    Dim loopCount As Integer
       
With Application
     .EnableEvents = False
     .ScreenUpdating = False
    End With
   
With Email
      .Display
      .To = ""
      .CC = ""
      .BCC = ""
      .Subject = "Report " & asofDate
      .Attachments.Add ActiveWorkbook.FullName
      .HTMLBody = "<style><font type='calabri (body)' size='3'>" & StartMsg & "<br><br>" & Run("EmailImages") & "<br><br>" & EndMsg & Signature & "</font>"

End With


    Set Email = Nothing
    Set olApp = Nothing
   
End Sub


_________
Function EmailImages() As Collection
   

    Dim Sht As Excel.Worksheet
        Set Sht = ActiveWorkbook.Sheets("Dashboard")
    Dim olApp As Object
        Set olApp = CreateObject("Outlook.Application")
    Dim Email As Object
        Set Email = olApp.CreateItem(0)
    Dim wdDoc As Word.Document
        Set wdDoc = Email.GetInspector.WordEditor
Dim loopCount As Integer
   
    'Ranges
    Dim r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14, r15, r16, r17, r18, r19, r110 As range
        Set r1 = Sht.range("A8:AA33")
        Set r2 = Sht.range("A34:AA56")
        Set r3 = Sht.range("A57:AA84")
        Set r4 = Sht.range("A85:AA107")
        Set r5 = Sht.range("A108:AA130")
        Set r6 = Sht.range("A131:AA154")
        Set r7 = Sht.range("A155:AA177")
        Set r8 = Sht.range("A178:AA201")
        Set r9 = Sht.range("A202:AA225")
        Set r10 = Sht.range("A226:AA248")
        Set r11 = Sht.range("A249:AA271")
        Set r12 = Sht.range("A272:AA294")
        Set r13 = Sht.range("A295:AA317")
        Set r14 = Sht.range("A318:AA340")
        Set r15 = Sht.range("A341:AA363")
        Set r16 = Sht.range("A364:AA386")
        Set r17 = Sht.range("A387:AA409")
        Set r18 = Sht.range("A410:AA433")
        Set r19 = Sht.range("A434:AA457")
        Set r20 = Sht.range("A457:AA484")
       
Sht.Activate
    r1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r3.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r4.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r5.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r6.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r7.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r8.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r9.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r10.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r11.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r12.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r13.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r14.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r15.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r16.CopyPicture Appearance:=xlScreen, Format:=xlPicture
       On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r17.CopyPicture Appearance:=xlScreen, Format:=xlPicture
      On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r18.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r19.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0
Sht.Activate
    r20.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     On Error GoTo ErrHandler:
    wdDoc.Application.Selection.PasteAndFormat Type:=wdChartPicture
    loopCount = 0


ErrHandler:
    'Limit resume option
    If loopCount < 8000 Then
        loopCount = loopCount + 1
        Resume
    End If
End Function