Extract and include senders email in forwarded message?

[perola.rike]

I have a code in the vba-module "This outlook session" that forwards all my outlook mail to my gmail account. What I need is a code (if possible) that inserts the original senders email in the forwarded message. Is this possible?

[skatonni]

See Processing Incoming E-mails with Macros (http://www.slipstick.com/developer/processing-incoming-e-mails-with-macros/)

Something like this where item is the incoming mail.


Dim newMail As mailItem

Set newMail = CreateItem(olMailItem)

With newMail
.To = "address"
.Attachments.Add Item
.Display ' .Send
End With

Set newMail = Nothing

[perola.rike]

Thank you for answering, I did some testing, but the code you suggested caused Outclook to crash/restart.... I have the following attached code pasted in "This outlook session". Any ideas how to integrate your suggested code with my code?14954

[skatonni]

Starting code:


Public Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryID As Variant

On Error Resume Next

For Each varEntryID In Split(EntryIDCollection, ",")
Dim objOriginalItem As mailItem
Set objOriginalItem = Application.GetNamespace("MAPI").GetItemFromID(varEntryID)
Dim objForwardedItem As mailItem
Set objForwardedItem = objOriginalItem.Forward
Do Until objForwardedItem.Attachments.count = 0
objForwardedItem.Attachments.Remove (1)
Loop

objForwardedItem.To = "address"
objForwardedItem.send
Next
End Sub


Revised code something like this:

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim varEntryID As Variant

Dim objOriginalItem As mailItem
Dim newMail As mailItem

On Error Resume Next

For Each varEntryID In Split(EntryIDCollection, ",")

Set objOriginalItem = Application.GetNamespace("MAPI").GetItemFromID(varEntryID)

Do Until objOriginalItem.Attachments.count = 0
objOriginalItem.Attachments.Remove (1)
Loop

Set newMail = CreateItem(olMailItem)

With newMail
.To = "address"
.Attachments.Add objOriginalItem
.Display ' .Send
End With

Next

ExitRoutine:
Set objOriginalItem = Nothing
Set newMail = Nothing

End Sub

[skatonni]

I probably misunderstood the question.


Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim varEntryID As Variant

'On Error Resume Next ' Not a good idea

For Each varEntryID In Split(EntryIDCollection, ",")

Dim objOriginalItem As Object
Set objOriginalItem = Application.GetNamespace("MAPI").GetItemFromID(varEntryID)

Dim objForwardedItem As mailItem

If TypeOf objOriginalItem Is mailItem Then

Set objForwardedItem = objOriginalItem.Forward
Do Until objForwardedItem.Attachments.count = 0
objForwardedItem.Attachments.Remove (1)
Loop

objForwardedItem.To = "address"
objForwardedItem.Display

objForwardedItem.HTMLBody = objOriginalItem.SenderEmailAddress & objForwardedItem.HTMLBody

' or
'objForwardedItem.body = objOriginalItem.SenderEmailAddress & objForwardedItem.body

'objForwardedItem.send

End If

Next
End Sub

[perola.rike]

Thank you! I tried your first suggestion which worked nice - it included the original sender's email adress (as a text string) in the forwarded mail (exactly what I needed)!

Looking forward to test your last code as well!