Question

我有以下代码，该代码基于两个Excel工作表中的数据生成Outlook电子邮件

“ Sheet1” ：（包含收件人信息）
“配置”（包含对附件链接，主题行，电子邮件正文的句子等的引用）

该代码还会在身体中央创建嵌入的图像，并在图像的上方/下方创建句子。

问题：该代码可以正常运行，但可以在单个Outlook电子邮件中打开所有内容。我需要能够遍历“ A列”中的所有行项目并填充单独的电子邮件。

我认为代码缺少一些简单的东西。我在网上进行了研究，但找不到内嵌图片和循环播放的示例。任何帮助表示赞赏。

代码示例：

Sub create_emails()
Dim wb As Workbook
Dim reportsRange As Range
Dim xlCell As Range
Dim SendID
Dim Subject
Dim Body
Dim olMail As Object
Dim fileattach, ccid, wimage, sig, mimage, msub, wsub, cname, cemail, sdate, mname, mfrom, wfrom As String
Dim s1, s2, s3, s4, s5 As String
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(0)
Set Doc = olMail.GetInspector.WordEditor
Dim oAttach As Object
Set wb = ActiveWorkbook
Set reportsRange = Range("A2", Range("A" & Cells.Rows.Count).End(xlUp))

'configuration references
s1 = wb.Sheets("Config").Range("c14").Value
s2 = wb.Sheets("Config").Range("c15").Value
s3 = wb.Sheets("Config").Range("c16").Value
s4 = wb.Sheets("Config").Range("c17").Value
s5 = wb.Sheets("Config").Range("c18").Value
fileattach = wb.Sheets("Config").Range("c3").Value
ccid = wb.Sheets("Config").Range("c4").Value
mfrom = wb.Sheets("Config").Range("c5").Value
wfrom = wb.Sheets("Config").Range("c8").Value
mimage = wb.Sheets("Config").Range("c6").Value
wimage = wb.Sheets("Config").Range("c9").Value
msub = wb.Sheets("Config").Range("c7").Value
wsub = wb.Sheets("Config").Range("c10").Value
sig = wb.Sheets("Config").Range("c11").Value

'recipient references
mname = wb.Sheets("Sheet1").Range("b2").Value
sdate = wb.Sheets("Sheet1").Range("d2").Value
cname = wb.Sheets("Sheet1").Range("c2").Value
cemail = wb.Sheets("Sheet1").Range("a2").Value

For Each xlCell In reportsRange
If xlCell.Value <> "" Then
With olMail
.SentOnBehalfOfName = mfrom
.To = SendID
.CC = ccid
.Subject = msub
.Attachments.Add mimage, olByValue, 0
.Attachments.Add sig, olByValue, 0
.Attachments.Add fileattach
.HTMLBody = .HTMLBody & "<font color=""#1a5276"" face=""AmplitudeTF""> Hi " & xlCell.Offset(0, 1).Value _
            & ",<br><br>We have " & xlCell.Offset(0, 2).Value & " joining your team on " & xlCell.Offset(0, 3).Value & "!<br><br>" _
            & s1 & "<br><br>" & s2 & "<br>" _
            & "<img src='cid:mon.png'" & "width='800' height='500'><br><br>" _
            & s3 & "</font><br><font face=""AmplitudeTF"" color=""#7d6608"">" & s4 _
            & "</font><font face=""AmplitudeTF"" color=""#1a5276""><br><br>Regards,<br>" _
            & "<img src='cid:gps.png'" & "<br>" _
            & s5 & "</font></span>"
.display
End With
End If
Next xlCell
Set objOutlook = Nothing
End Sub

Excel VBA在同一电子邮件中生成Outlook电子邮件

0 个答案: