Sending Email with PNG image in Outlook Body using VBA

问题

After doing a thorough research in the internet, I was able to build the following codes:

Sub EmailSuccess()

    Dim OutlookApplication As Outlook.Application
    Dim OutlookMailItem As Outlook.MailItem

    Dim Recipients As Object
    Dim myRecipients As Outlook.Recipient
    Dim sTo As Object
    Dim CCs As Object
    Dim myCCs As Outlook.Recipient
    Dim sCc As Object
    Dim emailContent As String

    Dim OutDocSto As String
    Dim ArchiveLinks As String
    Dim KendoxDocs As String
    Dim LinksGE As String
    Dim PicSheet2 As Object
    Dim PicSheet3 As Object

    Application.ScreenUpdating = False

    Set OutlookApplication = New Outlook.Application
    Set OutlookMailItem = OutlookApplication.CreateItem(0)

    '=========================================START========================================='

        Workbooks("ConfigFile_Kendox Monitoring.xlsm").Activate
        Sheets("Email").Activate

        'Set Recipient value
        Range("A2").Select
            Set Recipients = Range(ActiveCell, ActiveCell.End(xlDown))

        'Set CC Value
        ActiveCell.Offset(0, 1).Select
            Set CCs = Range(ActiveCell, ActiveCell.End(xlDown))

        'Set greetings
        emailContent = "<b>" & Range("D2").Value & "</b>" & "<br>" & "<br>" & _
            Range("D3").Value & "<br>" & "<br>" & Range("D4").Value & "<br>" & "<br>"

        'Copy Outbound Document Storage screenshot path
        Range("I2").Select
            OutDocSto = ActiveCell.Value

        'Copy Archive Links screenshot path
        ActiveCell.Offset(0, 1).Select
            ArchiveLinks = ActiveCell.Value

        'Assign value for KendoxDocs
        KendoxDocs = "<b>" & "<u>" & Range("D5").Value & "</b>" & "</u>" & "<br>" & "<br>"

        'Assign value for LinksGE
        LinksGE = "<br>" & "<br>" & "<b>" & "<u>" & Range("D6").Value & "</b>" & "</u>" & "<br>" & "<br>"


        'Delete contents for Sheet2
        Sheets("OutDocStorage").Activate
        For Each PicSheet2 In ActiveSheet.Pictures
            PicSheet2.Delete
        Next PicSheet2

        'Insert OutDocSto in OutDocSto sheet
        Sheets("OutDocStorage").Activate
        Range("A1").Select
        ActiveSheet.Pictures.Insert (OutDocSto)

        'Delete contents for Sheet3
        Sheets("ArchiveLinks").Activate
        For Each PicSheet3 In ActiveSheet.Pictures
            PicSheet3.Delete
        Next PicSheet3

        'Insert ArchiveLinks in ArchiveLinks sheet
        Worksheets("ArchiveLinks").Activate
        Range("A1").Select
        ActiveSheet.Pictures.Insert (ArchiveLinks)

        'Set value for eBodyODS
        Sheets("OutDocStorage").Activate
            Set eBodyODS = ThisWorkbook.Sheets("OutDocStorage").UsedRange

        'Set value for eBodyArcLinks
        Sheets("ArchiveLinks").Activate
            Set eBodyArcLinks = ThisWorkbook.Sheets("ArchiveLinks").UsedRange


        On Error Resume Next

            With OutlookMailItem

                .Display

                'Assign Recipients in TO field
                For Each sTo In Recipients
                    Set myRecipients = OutlookMailItem.Recipients.Add(sTo)
                    myRecipients.Type = olTo

                    myRecipients.Resolve
                    If Not myRecipients.Resolved Then
                        myRecipients.Delete
                    End If

                Next sTo

                'Assign CCs in CC field
                For Each sCc In CCs
                    Set myCCs = OutlookMailItem.Recipients.Add(sCc)
                    myCCs.Type = olCC

                    myCCs.Resolve
                    If Not myCCs.Resolved Then
                        myCCs.Delete
                    End If

                Next sCc

                'Assign value for Subject
                .Subject = Workbooks("ConfigFile_Kendox Monitoring.xlsm").Sheets("Email").Range("C2").Value

                'Set Body
                .HTMLBody = emailContent & KendoxDocs & "<img src = OutDocSto>" & LinksGE & "<img src = ArchiveLinks>"

                .Display


            End With

        On Error GoTo 0

        Set OutlookMailItem = Nothing
        Set OutlookApplication = Nothing
        Application.ScreenUpdating = True

End Sub

This code is expected to attach a PNG photo in my Outlook email body. The path of the two photos were declared in the OutDocSto and ArchiveLinks strings. However, it doesn't gave the result that I am expecting for. What could be the possible and easiest way to embed photos. thanks

回答1:

I believe if you edit your code:

HTMLBody = emailContent & KendoxDocs & "<img src = OutDocSto>" & LinksGE & "<img src = ArchiveLinks>"

To this, then it might do the job:

HTMLBody = emailContent & KendoxDocs & "<img src ='" &  OutDocSto & "'>" & LinksGE & "<img src ='" &  ArchiveLinks & "'>"

来源：https://stackoverflow.com/questions/47508927/sending-email-with-png-image-in-outlook-body-using-vba