How to send email from excel using VBA with Cell Range (Including Images) as Email Bo
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"
Code:
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
