Outlook Macro - Obtain email address from Email Body and Forward

[NEWB_2_VBA]

Hi guys,

1st Thread so go easy on me!

I'm only a basic user of VBA and this is mainly in excel so takes me a while to understand coding.

I'm looking for a macro to read only NEW emails, obtain the email address from within the body of the email and then forward that email to the email address obtained from the body text.

The emails will always come from a dedicated email address, so i will have a rule setup to run a script once a new email is received from this address. Can anyone help with the code required for for the obtaining of the email address from the body and the auto forward of the email?

Thanks

 

[NEWB_2_VBA]

With a bit of help i've obtained the code below which works perfect to find the email address and forward the selected email to an email address contained in the body of the email.

The problem i am having is that it works on whatever email is currently selected in my Outlook. I need the macro to work on the unread new item in my inbox?
I know this is down to the code "For Each olItem In Application.ActiveExplorer.Selection" but i do not know what to replace this with, any help would be great!


Sub SendOnMessage(MyMail As MailItem)
Dim olItem As Outlook.MailItem
Dim olOutMail As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vAddr As Variant
Dim sAddr As String
Dim i As Long
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "@") Then
sAddr = vText(i)
Exit For
End If
Next i
If InStr(1, sAddr, "HYPERLINK") Then
vText = Split(sAddr, Chr(34))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "@") Then
sAddr = vText(i)
Exit For
End If
Next i
End If
sAddr = Replace(sAddr, "mailto:", "")
Set olOutMail = olItem.Forward
With olOutMail
.To = sAddr
.HTMLBody = "Confirmation" & vbCr & .HTMLBody
.Display 'Change to .Send after testing'
End With
Next olItem
Set olItem = Nothing
Set olOutMail = Nothing
End Sub