Excel VBA Body in der Outlook-E-Mail weiterleiten

Question

Ich versuche, E-Mails basierend auf dem Thema in der A-Spalte durch Schleifen weiterzuleiten. Es funktioniert perfekt, aber ich möchte auch den Inhalt in der C-Spalte zu jeder der entsprechenden Mail hinzufügen.

Löschen Sie auch die von und zu Details aus der ersten Mail.

Anfrage Vorlage:

Der Körper Inhalt auch den Spaltenwert verwenden soll, wie unten erwähnt.

Kann jemand mir helfen, entfernen und nimmt diese Details in der unten ..

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("sen@aa.com") 
       Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient 
       MsgFwd.SentOnBehalfOfName = "doc@aa.com" 


        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

neue Variable hinzufügen als String Dim EmailBody As String dann Spalte C EmailBody = .Cells(i, 3).Value mit zuweisen in Ihrem Do Loop

die folgenden von der Item.Forward Körper zu entfernen, fügen Sie einfach Ihre Item.Body zu Ihrem MsgFwd.Body - es sollte die gesamte Vorwärts E-Mail Körper mit Item.Body nur ersetzen

---

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

---

Beispiel

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("sen@aa.com") 
       Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient 
       MsgFwd.SentOnBehalfOfName = "doc@aa.com" 

       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