将Excel VBA包含在转发的Outlook电子邮件中

我试图通过循环转发基于A列中提供的主题的电子邮件。 它的工作完美，但我也想把C列中的内容包含到每个相应的邮件中。

同时从最初的邮件中删除从和详细信息。

请求模板：

正文内容也应该使用如下所述的列值。

有人可以帮我删除，并在下面包含这些细节..

Option Explicit Public Sub Example() Dim olApp As Outlook.Application Dim olNs As Outlook.Namespace Dim Inbox As Outlook.MAPIFolder Dim Item As Variant Dim MsgFwd As MailItem Dim Items As Outlook.Items Dim Email As String Dim Email1 As String Dim ItemSubject As String Dim lngCount As Long Dim i As Long Dim RecipTo As Recipient Dim RecipCC As Recipient Dim RecipBCC As Recipient Dim onbehalf As Variant Set olApp = CreateObject("Outlook.Application") Set olNs = olApp.GetNamespace("MAPI") Set Inbox = olNs.GetDefaultFolder(olFolderInbox) Set Items = Inbox.Items i = 2 ' i = Row 2 With Worksheets("Sheet1") ' Sheet Name Do Until IsEmpty(.Cells(i, 1)) ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) Email = .Cells(i, 16).Value '(i, 2) = (Row 2,Column 2) Email1 = .Cells(i, 2).Value '// Loop through Inbox Items backwards For lngCount = Items.Count To 1 Step -1 Set Item = Items.Item(lngCount) If Item.Subject = ItemSubject Then ' if Subject found then Set MsgFwd = Item.Forward Set RecipTo = MsgFwd.Recipients.Add(Email1) ' add To Recipient Set RecipTo = MsgFwd.Recipients.Add("[e-mail]") Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient MsgFwd.SentOnBehalfOfName = "[e-mail]" RecipTo.Type = olTo RecipBCC.Type = olBCC MsgFwd.Display End If Next ' exit loop i = i + 1 ' = Row 2 + 1 = Row 3 Loop End With Set olApp = Nothing Set olNs = Nothing Set Inbox = Nothing Set Item = Nothing Set MsgFwd = Nothing Set Items = Nothing MsgBox "Mail sent" End Sub 

Answer 1

添加新的variables作为stringDim EmailBody As String然后分配给C列EmailBody = .Cells(i, 3).Value与在你的Do Loop

要从Item.Forward主体中删除以下内容，只需将您的Item.Body添加到您的MsgFwd.Body – 它应该只用Item.Bodyreplace整个转发的电子邮件主体

---

MsgFwd.HTMLBody = EmailBody & "<BR>" & "<BR>" & Item.HTMLBody

---

例

 Dim EmailBody As String With Worksheets("Sheet1") ' Sheet Name Do Until IsEmpty(.Cells(i, 1)) ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) Email = .Cells(i, 16).Value '(i, 2) = (Row 2,Column 2) Email1 = .Cells(i, 2).Value EmailBody = .Cells(i, 3).Value '// Loop through Inbox Items backwards For lngCount = Items.Count To 1 Step -1 Set Item = Items.Item(lngCount) If Item.Subject = ItemSubject Then ' if Subject found then Set MsgFwd = Item.Forward Set RecipTo = MsgFwd.Recipients.Add(Email1) ' add To Recipient Set RecipTo = MsgFwd.Recipients.Add("[e-mail]") Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient MsgFwd.SentOnBehalfOfName = "[e-mail]" RecipTo.Type = olTo RecipBCC.Type = olBCC Debug.Print Item.Body ' Immediate Window MsgFwd.HTMLBody = EmailBody & "<BR>" & "<BR>" & Item.HTMLBody MsgFwd.Display End If Next ' exit loop