excel vba发送带有嵌入图像的电子邮件

Question

我使用下面的宏创建带有嵌入图片的电子邮件，但它不起作用，因为我一直在接收

运行时错误 5“无效的过程调用或参数”

并突出显示此代码.BodyFormat = olFormatHTML。

Sub Outlook_Email_With_Inline_Image()
    'Add reference to Microsoft Outlook Object Library
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    'Dim OutApp As Outlook.Application
    'Dim oOutlookEmail As Outlook.MailItem

    'Create New Outlook Email Item to Attach Image(s)
    Set OutApp = CreateObject("Outlook.Application")
    Set oOutlookEmail = OutApp.CreateItem(0)

    'Actual Excel VBA to send email with Embedded images
    With oOutlookEmail
        .To = "user@gmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "Congrats"
        .BodyFormat = olFormatHTML
        .Attachments.Add "C:\Users\Username\Pictures\Michael's Email Promotion\Angela.jpg", olByValue, 0
        sImgName = "ImageFile.img"
        .HTMLBody = "<img src='cid:" & sImgName & "'" & " ><br>" 'Mention only the image file name not its path
        'Or Use this below line.
        '.HTMLBody = "<img src='" & sImgName & "'" & " ><br>"
        .Display
    '    .Send 'or just put .Display to check
    End With

    Set OutlookMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

Sub email()

Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object

Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailSig As String



For Each ToCc In ActiveSheet.[A2:A2]


'=============================================================

Dim ToEmail, CcEmail, ToNm, CcNm As String
Dim DescrDt, DescrID, DescrNm As String

    ToNm = Cells(ToCc.Row, [C1].Column).Value
    CcNm = Cells(ToCc.Row, [G1].Column).Value
    ToEmail = Cells(ToCc.Row, [E1].Column).Value
    CcEmail = Cells(ToCc.Row, [I1].Column).Value

    DescrID = Cells(ToCc.Row, [B1].Column).Value
    DescrNm = Cells(ToCc.Row, [D1].Column).Value
    DescrDt = "20190426"



'=============================================================
'''determine strBody --email message

Dim strFontSize, strFontName, strFontColor As String
    strFontName = "Arial"
    strFontColor = fAggieGray
    strFontSize = 13


Greeting = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
            "<span style=""color:" & strFontColor & """>" & _
    Application.WorksheetFunction.Proper(ToNm) & "," & "<br> <br>" & _
            "</span style=""color:" & strFontColor & """>" & "</BODY>"



emailSig = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
            "<span style=""color:" & strFontColor & """>" & _
    "<br> <br>" & "- OE & HRIS Team" & "<br>" & "______________________" & "<br> <br>" & _
            "</span style=""color:" & strFontColor & """>" & "</BODY>" & _
            "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size: 10px;"">" & _
            "<span style=""color:" & strFontColor & """>" & _
    "[Email generated through Excel Macros and Google meme download - source data: October 3, 2019]" & _
            "</span style=""color:" & strFontColor & """>" & "</BODY>"



Set colAttach = oEmail.Attachments
Set oAttach1 = colAttach.Add("C:\Users\AA.jpg")
Set oAttach2 = colAttach.Add("C:\Users\BB.png")
Set oAttach3 = colAttach.Add("C:\Users\CC.jpg")
Set oAttach4 = colAttach.Add("C:\Users\DD.gif")
Set oAttach5 = colAttach.Add("C:\Users\EE.png")
Set oAttach6 = colAttach.Add("C:\Users\FF.jpg")
Set oAttach7 = colAttach.Add("C:\Users\GG.jpg")

Set olkPA1 = oAttach1.PropertyAccessor
Set olkPA2 = oAttach2.PropertyAccessor
Set olkPA3 = oAttach3.PropertyAccessor
Set olkPA4 = oAttach4.PropertyAccessor
Set olkPA5 = oAttach5.PropertyAccessor
Set olkPA6 = oAttach6.PropertyAccessor
Set olkPA7 = oAttach7.PropertyAccessor



olkPA1.SetProperty PR_ATTACH_CONTENT_ID, "AA.jpg"
olkPA2.SetProperty PR_ATTACH_CONTENT_ID, "BB.png"
olkPA3.SetProperty PR_ATTACH_CONTENT_ID, "CC.jpg"
olkPA4.SetProperty PR_ATTACH_CONTENT_ID, "DD.gif"
olkPA5.SetProperty PR_ATTACH_CONTENT_ID, "EE.png"
olkPA6.SetProperty PR_ATTACH_CONTENT_ID, "FF.jpg"
olkPA7.SetProperty PR_ATTACH_CONTENT_ID, "GG.jpg"


oEmail.Close olSave



oEmail.HTMLBody = Greeting & "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
            "<span style=""color:" & strFontColor & """>" & _
    "<br> <br>" & _
                    "<img src=""cid:FF.jpg""height=520 width=750>" & _
                    "<br> <br>" & "<img src=""cid:AA.jpg""height=520 width=750>" & _
                    "<br> <br>" & "<img src=""cid:BB.png""height=520 width=750>" & _
                    "<br> <br>" & "<img src=""cid:DD.gif""height=520 width=750>" & _
                    "<br> <br>" & "<img src=""cid:GG.jpg""height=520 width=750>" & _
                    "<br> <br>" & "<img src=""cid:EE.png""height=520 width=750>" & _
                    "</body>"

oEmail.Save
oEmail.To = "MM@email.com"
oEmail.CC = "AA@email.com"

oEmail.Subject = "Congrats " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
oEmail.display
'oEmail.send



NEXT_ToCC:
    Set aEmail = Nothing
    Set olInsp = Nothing
    Set myDoc = Nothing
    Set oRng = Nothing
Next ToCc

'oEmail.Send

Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing


End Sub

Answer 2

如果您使用后期绑定，则不能使用 Outlook OlBodyFormat 枚举的成员。

olFormatHTML 对应于2。

Sub Outlook_Email_With_Inline_Image()
    Const olFormatHTML As Long = 2
    ...
    .BodyFormat = olFormatHTML
    ...
End Sub

另外 - 将 Option Explicit 添加到模块顶部并声明 所有 变量。