CODEWITHSUNDEEP
excelvbaoutlook
Kelvin
Kelvin

Reputation: 160

Excel VBA to include body in the forwarded outlook email

I am trying to forward emails based on the subject provided in the A column by looping. Its working perfectly, but I would also like to include the content in the C column to each of the corresponding mail.

Also delete the from and to details from the initial mail.

enter image description here

Request template:

The body content should also use the column value as mentioned below.

enter image description here

Can some one help me remove and include this details in the below.. 

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("[email protected]")
                Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient
                MsgFwd.SentOnBehalfOfName = "[email protected]"


                    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

Upvotes: 4

Views: 1340

Answers (1)

0m3r
0m3r

Reputation: 12495

Add new variable as string Dim EmailBody As String then assign to column C EmailBody = .Cells(i, 3).Value with in your Do Loop

To remove the following from the Item.Forward body, simply add your Item.Body to your MsgFwd.Body - it should replace the whole forward Email body with Item.Body only

enter image description here

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

Example

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("[email protected]")
                Set RecipBCC = MsgFwd.Recipients.Add(Email) ' add BCC Recipient
                MsgFwd.SentOnBehalfOfName = "[email protected]"

                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

Upvotes: 2

Related Questions