Встраивание файла HTML с изображениями в сообщение электронной почты, созданное приложением Excel VBA, отправленное через Outlook

Question

Я пишу фрагмент кода для отправки персонализированной электронной почты, созданной в Excel VBA, нескольким людям. Письмо содержит один простой текст, который содержит персонализированное электронное письмо, за которым следует HTML-файл с изображениями. Я попробовал следующий код, но изображения просто не отображаются.

    Sub Mail_Outlook_With_Html_Doc()

            Dim OutApp As Object
            Dim OutMail As Object
            Dim strbody As String
            Dim oFSO As Object
            Dim oFS As Object
            Dim sText As String


            Set oFSO = CreateObject("Scripting.FileSystemObject")
            Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")

            Do Until oFS.AtEndOfStream
                sText = oFS.ReadAll()
            Loop

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

           'strbody = personalized email body generated here

            On Error Resume Next

            With OutMail
                .display
                .To = ToAdd
                .CC = 
                .BCC = ""
                .Subject = "Test Email"
                .ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
                .HTMLBody = strbody & sText
                .Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
            Set OutApp = Nothing
    End Sub

Упомянутый выше invit.htm содержит изображения, которые не отображаются при отправке электронного письма. Ни в отправленных сообщениях электронной почты, ни в полученных сообщениях электронной почты. Кто-нибудь может предложить лучший код? Я не связан с VBA и не собираюсь куда-нибудь с этим кодом.

Большое спасибо заранее

Answer 1

Вот пример, который работает для меня, вам нужно адаптировать его в соответствии с вашими потребностями.Это вставит изображение в тело письма и прикрепит его из того, что я помню.Пожалуйста, обратите внимание, что вам сначала нужно отобразить электронную почту, а затем отправить ее, что является единственным способом показать на другом устройстве, я узнаю, что это нелегкий путь.Это можно сделать с помощью кода, как показано в примере ниже, если вы хотите просмотреть и просмотреть электронное письмо, просто закомментируйте .Send. После того, как вы удовлетворены, вы можете нажать send вручную.

Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String

Sub GenerateInfo()

    Dim WS As Worksheet
    Dim lrow As Long
    Dim cRow As Long

    Set WS = ActiveSheet

    With WS
        lrow = .Range("E" & .Rows.Count).End(xlUp).Row
        Application.ScreenUpdating = False
        For cRow = 2 To lrow
            If Not .Range("L" & cRow).value = "" Then
                titleName = .Range("D" & cRow).value
                firstName = .Range("E" & cRow).value
                lastName = .Range("F" & cRow).value
                fullName = firstName & " " & lastName
                clientEmail = .Range("L" & cRow).value

                Call SendEmail

                .Range("Y" & cRow).value = "Yes"
                .Range("Y" & cRow).Font.Color = vbGreen

            Else
                .Range("Y" & cRow).value = "No"
                .Range("Y" & cRow).Font.Color = vbRed
            End If
        Next cRow
    End With

    Application.ScreenUpdating = True

    MsgBox "Process completed!", vbInformation

End Sub
Sub SendEmail()

    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim sigString As String
    Dim Signature As String
    Dim insertPhoto As String
    Dim photoSize As String

    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0)

    'Change only Mysig.htm to the name of your signature
    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Marius.htm"

    If Dir(sigString) <> "" Then
        Signature = GetBoiler(sigString)
    Else
        Signature = ""
    End If

    insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
    photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here

    emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
                    "<p>I hope my email will find you very well." & _
                    "<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
                    "<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
                    "<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
                    "<p>Please feel free to contact me and book an appointment." & _
                    "<p>I look forward to seeing you then." & _
                    "<p>" & photoSize & _
                    "<p>Kind Regards," & _
                    "<br>" & _
                    "<br><strong>Marius</strong>" & _
                    "<br>Assistant Store Manager" & _
                    "<p>"


    With outlookMail
        .To = clientEmail
        .CC = ""
        .BCC = ""
        .Subject = "PRIVATE SALE"
        .BodyFormat = 2
        .Attachments.Add insertPhoto, 1, 0
        .HTMLBody = emailMessage & Signature 'Including photo insert and signature
        '.HTMLBody = emailMessage & Signature 'Only signature
        .Importance = 2
        .ReadReceiptRequested = True
        .Display
        .Send

    End With

    Set outlookApp = Nothing
    Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String

    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function