邮件合并发送如何插入对应图片

zzp000

各位大神，求助邮件合并如何插入对应图片

背景：
领导想在邮件正文中向每位员工一对一发送其工作证明的图片，注意是插入到邮件正文中，而不是作为附件
如下:

论坛里也看过类似的，制作不同照片的工卡等，但最后都是导成单个邮件，没有发送的环节
附件是示例的数据，供参考，也可以不用。手里的图片源名称是乱码，重命名后可以保证按工号或者姓名对应，这个我再想别的办法。
求助各位大神帮帮忙，我已经每封邮件逐一插入图片插到吐血了

约定的童话

Sub SendEmail()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i, arr
    Dim OutlookApp As Outlook.Application
    Dim OutlookItem As Outlook.MailItem
    Sheets("Goldenlist Data").Copy
    ActiveWorkbook.Close True, "D:\" & "Golden sample daily check list" & Format(Now(), "yyyymmdd") & ".xlsx"
    m = Split([a2], ";")
    pic = "<img src=" & ThisWorkbook.path & "\图表1.jpg /><br />"
    pic = pic + "<img src=" & ThisWorkbook.path & "\666.jpg /><br />"
    Set OutlookApp = New Outlook.Application
    Set OutlookItem = OutlookApp.CreateItem(olMailItem)
    With OutlookItem
        Adress = [a2]: Title = [b2]: Text = [c2]: 抄送 = [d2]: 附件 = "D:\" & "Golden sample daily check list" & Format(Now(), "yyyymmdd") & ".xlsx"
        .To = Adress
        .Subject = Title
        .CC = 抄送
        .HTMLBody = Text & pic
        .Attachments.Add 附件
        .Display
        .Send
    End With
    Kill ThisWorkbook.path & "\666.jpg"
    MsgBox "Send Complete！", 64, "Tips!"
End Sub
修改再用。。。

zzp000

约定的童话 发表于 2021-9-28 22:17
Sub SendEmail()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

谢谢！VBA小白一枚，我再琢磨下

zzp000

约定的童话 发表于 2021-9-28 22:17
Sub SendEmail()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

哥，跑不动啊，图片会变成空白的

zzp000

约定的童话 发表于 2021-9-28 22:17
Sub SendEmail()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim i, endRow
   
5.     Dim OutlookApp As Outlook.Application
   
6.     Dim OutlookItem As Outlook.MailItem
   
7.     endRow = Range("a" & Rows.Count).End(xlUp).Row
   
8.     Set OutlookApp = New Outlook.Application
   
9.     For i = 2 To endRow
   
10.     picname = Cells(i, 3).Value
    
11.     pic = "<img src=" & ThisWorkbook.Path & "" & picname & " /><br />"
    
12.     Set OutlookItem = OutlookApp.CreateItem(olMailItem)
    
13.     With OutlookItem
    
14.         .BodyFormat = olFormatHTML
    
15.         .To = Cells(i, 4).Value
    
16.         .Subject = "啦啦"
    
17.         .HTMLBody = pic
    
18.         .Display               
    
19.         .Send
    
20.     End With
    
21.     Set OutlookItem = Nothing '销毁Mail对象
    
22.     Next
    
23.     MsgBox ("邮件全部发送完成！")
    
24.     Set OutlookApp = Nothing '销毁Outlook对象
    
25.     Application.ScreenUpdating = True
    
26.     Application.DisplayAlerts = True
    
27. End Sub
    

复制代码