Image do not display in email (red cross only appears)

[missrutele]

Please someone help, I have a code to create PDF file from range of cells add as email attachement and send. Right now I need to add an image in the end of email body, it worked before but now only red cross appears in the end. What is wrong and how can I fix it?
Sub AttachActiveSheetPDFXX()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object

'SaveAsStr = ActiveWorkbook.Path & "\" & ActiveSheet.Range("J1").Value
SaveAsStr = ActiveSheet.Range("J1").Value

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=SaveAsStr & ".pdf", _
OpenAfterPublish:=False

' Not sure for what the Title is
Title = Range("K15")

' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & " " & Range("J1") & ".pdf"

' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0

' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)

' Prepare e-mail
.Subject = Range("K17")
.To = Range("K5") ' <-- Put email of the recipient here
.CC = Range("K6") ' <-- Put email of 'copy to' recipient here
.Body = Range("K8") & vbLf & vbLf _
& Range("K9") & vbLf & vbLf _
& Range("K10") & vbLf & vbLf _
& Range("K11") & vbLf & vbLf _
& Range("K12") & vbLf & vbLf _
& Range("K13") & vbLf _
& Application.UserName & vbLf & vbLf
.HTMLBody = .HTMLBody & "<img src='cid:Capture.PNG'" & "width='500? height='200'><br>"
.Display
.Attachments.Add PdfFile

' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0

End With

' Delete PDF file
Kill PdfFile

' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit

' Release the memory of object variable
Set OutlApp = Nothing
Range("L25").Value = Range("L25").Value + 1

End Sub

 

[VBE313]

Home | Ron de Bruin Excel Automation

Welcome to https://www.rondebruin.nl

www.rondebruin.nl