Chèn ảnh trực tiếp vào mail Outlook bằng VBA

[moihocvba]

Chào anh chị GPE,
Anh chị giúp em xem code này, em chèn ảnh trực tiếp vào mail Outlook, nhưng nó không hiển thị ạ, em cám ơn rất nhiều!

Sub SendEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Body As Worksheet
    Dim imgPath As String
    Dim img As Object
    Dim imgID As String

    On Error GoTo ErrorHandler

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

    imgPath = ThisWorkbook.Path & "\pic1.png"

    imgID = "pic1"

    With OutMail
        .To = Body.Range("B1").Value
        .Subject = Body.Range("A1").Value
        .Attachments.Add imgPath, , 0, imgID
        .HTMLBody = "<font face=""Times New Roman"" size=""4"">" & _
                    "<b>" & Body.Range("A2").Value & "</b><br>" & _
                    "<img src=""cid:" & imgID & """><br>" & _
                    "</font>"
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "Có lỗi xảy ra: " & Err.Description, vbCritical, "Lỗi"
End Sub

 

[Maika8008]

Sửa chữ "Chènh" trong tiêu đề đi bạn.

 

[moihocvba]

Sửa chữ "Chènh" trong tiêu đề đi bạn.

Dạ cám ơn anh đã nhắc nhở, em đã phát hiện ra lỗi sai và đã sửa ạ.

 

[nguyendang95]

Chào anh chị GPE,
Anh chị giúp em xem code này, em chèn ảnh trực tiếp vào mail Outlook, nhưng nó không hiển thị ạ, em cám ơn rất nhiều!

Sub SendEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Body As Worksheet
    Dim imgPath As String
    Dim img As Object
    Dim imgID As String

    On Error GoTo ErrorHandler

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

    imgPath = ThisWorkbook.Path & "\pic1.png"

    imgID = "pic1"

    With OutMail
        .To = Body.Range("B1").Value
        .Subject = Body.Range("A1").Value
        .Attachments.Add imgPath, , 0, imgID
        .HTMLBody = "<font face=""Times New Roman"" size=""4"">" & _
                    "<b>" & Body.Range("A2").Value & "</b><br>" & _
                    "<img src=""cid:" & imgID & """><br>" & _
                    "</font>"
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "Có lỗi xảy ra: " & Err.Description, vbCritical, "Lỗi"
End Sub

Code của bạn chưa cài đặt thuộc tính PR_ATTACH_CONTENT_ID (http://schemas.microsoft.com/mapi/proptag/0x3712001F) cho ảnh dưới dạng đính kèm ẩn của mail.
Mình sửa một số chỗ trong code như sau:

Public Sub SendEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Body As Worksheet
    Dim imgPath As String
    Dim img As Object
    Dim imgID As String
    Dim PA As Object
    Dim Att As Object
    Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    On Error GoTo ErrorHandler

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

    imgPath = ThisWorkbook.Path & "\pic1.png"

    imgID = "pic1"

    With OutMail
        .To = Body.Range("B1").Value
        .Subject = Body.Range("A1").Value
        Set Att = .Attachments.Add(imgPath)
        Set PA = Att.PropertyAccessor
        PA.SetProperty PR_ATTACH_CONTENT_ID, imgID
        .BodyFormat = 2
        .HTMLBody = "<font face=""Times New Roman"" size=""4"">" & _
                    "<b>" & Body.Range("A2").Value & "</b><br>" & _
                    "<img src=""cid:" & imgID & """><br>" & _
                    "</font>"
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "Có l?i x?y ra: " & Err.Description, vbCritical, "L?i"
End Sub

Xem thêm: PidTagAttachContentId Canonical Property