How to send email from excel using VBA with Cell Range (Including Images) as Email Body

[raghuram.star]

I want to send email from excel using VBA with Cell Range (Including Images) as Email Body, I have below code to send email as HTML body every this is coming to email body (formats & fonts) but Images are not displayed in email body. getting error "The image cannot be displayed. Your computer may not have enough memory to open the image, or the image may have been corrupted"

Sub Send_eMail()
    Call eMailRangeAsBody(WksQuote.Range("D18").Value, "Quote : eMail", "B2:N61")
End Sub


Public Sub eMailRangeAsBody(strTo As String, strSubject As String, rRange As String)
    
    Dim oBook As Excel.Workbook      ' Excel workbook
    Dim oSheet As Excel.Worksheet     ' Excel Worksheet
    
    Dim oOutlookApp As Object 'New Outlook.Application
    Dim oOutlookMessage As Object
    Dim oFSObj As Object
    Dim oFSTextStream As Object
    Dim rngeSend As Range
    Dim strHTMLBody As String
    Dim strTempFilePath As String
    
    Set oBook = ThisWorkbook
    Set oSheet = oBook.Worksheets(1)
    
    On Error Resume Next
    Set rngeSend = oSheet.Range(rRange)
    If rngeSend Is Nothing Then Exit Sub
    On Error GoTo 0
    
    Set oFSObj = CreateObject("Scripting.FilesystemObject")
    strTempFilePath = oFSObj.GetSpecialFolder(2)
    strTempFilePath = strTempFilePath & "\XLRange.htm"
    
    oBook.PublishObjects.Add(4, strTempFilePath, _
        oSheet.Name, rRange, 0, "", "").Publish True
    
    Set oOutlookApp = CreateObject("Outlook.Application")
    
    Set oOutlookMessage = oOutlookApp.CreateItem(0)
    
    Set oFSTextStream = oFSObj.OpenTextFile(strTempFilePath, 1)
    
    strHTMLBody = oFSTextStream.ReadAll
    
    strHTMLBody = Replace(strHTMLBody, "align=center", "align=left", _
        , , vbTextCompare)
    
    oOutlookMessage.HTMLBody = strHTMLBody
    oOutlookMessage.HTMLBody = strHTMLBody
    oOutlookMessage.To = strTo
    oOutlookMessage.Subject = strSubject
    
        'Attach images to email
        txtFpath = "C:\Images\"
        Pathf = fs.GetFolder(txtFpath)
        Set MyObject = New Scripting.FileSystemObject
        Set mySource = MyObject.GetFolder(Pathf)
        On Error Resume Next
        iCol = 4
        For Each myFile In mySource.Files
            If Left(myFile.Name, 14) = WksQuote.Range("I8").Value Then 'Attach all Quote related images
                FilePath = myFile
                oOutlookMessage.Attachments.Add (FilePath)
            End If
        Next


    oOutlookMessage.Display
    
    Call DeleteFile(strTempFilePath)
    
    Set oBook = Nothing
    Set oFSTextStream = Nothing
    Set oOutlookMessage = Nothing
    Set oOutlookApp = Nothing
    Set oFSObj = Nothing
End Sub

Some one please help me