# Outlook Macro - Obtain email address from Email Body and Forward



## NEWB_2_VBA (Aug 9, 2012)

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 (Aug 16, 2012)

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


----------

