Find email address in email body to copy the adress to the destination addres

[adelgadoq]

Hello,

I want to make an autoforwarding macro, lets say i have so little VBA Experience that i use it as a modular set. We have multiple accounts (e.g, Secondary Adress,) working in an office, but all the comunications should be made using a unique Primary Adress. Browsing over the internet i manage to gather this code. But i cant retrieve the adress email from the mesagges body:

............................................Email body example...............................

"Please Send to: adress 1; adress 2

IMPORTANT TEXT
IMPORTANT TEXT
IMPORTANT TEXT
IMPORTANT TEXT
IMPORTANT TEXT
IMPORTANT TEXT
IMPORTANT TEXT

Email signature
-----------------------------------------------------------------------

I just need to resend the IMPORTANT TEXT, using the adresses on the first line.

Could somebody help me?

See the code below:

Sub SendNew(Item As Outlook.MailItem)

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Dim strName As String
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)

strMsgBody = objMsg.Body
MsgBox strMsgBody
strEmailContents = ParseTextLinePair(strMsgBody, "Favor enviar a: ")

MsgBox strEmailContents


Msg = Item.Subject & " " & "a:"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = Item.Sender & " " & "desea enviar"
Help = "DEMO.HLP"
Ctxt = 1000

Response = MsgBox(Msg, Style, Title, Help, Ctxt)

If Response = vbNo Then
MsgBox "No Autorizado!"
Else

objMsg.Body = Item.Body
objMsg.Subject = "FW: " & Item.Subject
objMsg.Recipients.Add "adress x"
objMsg.Send
MsgBox "Enviado!"
End If

End Sub

Function ParseTextLinePair(strSource, strLabel)
' Sue Moshers code
'commented out type declaration for VBS usgage take out fer VB usage
Dim intLocLabel 'As Integer
Dim intLocCRLF 'As Integer
Dim intLenLabel 'As Integer
Dim strText 'As String

' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText) ' this i like
End Function

[skatonni]

objMsg.Recipients.Add strEmailContents
'or
'objMsg.To = strEmailContents