See Chapter 17: Working with Item Bodies https://msdn.microsoft.com/en-us/lib...ffice.12).aspx
Sub ForwardToAddr()
Dim objOL As Outlook.Application
Dim objItem As Object
Dim objFwd As Outlook.MailItem
Dim strAddr As String
Set objOL = Application
On Error Resume Next
' open the item to be sure it is what you want
Set objItem = objOL.ActiveInspector.currentItem
' otherwise you can use the method in the link
' and select a mailitem Set objItem = objOL.ActiveExplorer.Selection(1)
On Error GoTo 0
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objFwd = objItem.Forward
objFwd.To = "anotheraddress @ somewhere.com"
objFwd.Subject = ParseTextLinePair(objItem.body, "5.tour_booked :") & _
" " & ParseTextLinePair(objItem.body, "5.tour_price :")
objFwd.Display
Else
MsgBox "Open a mailitem", , "ForwardToAddr"
End If
Else
MsgBox "Open a mailitem", , "ForwardToAddr"
End If
Set objOL = Nothing
Set objItem = Nothing
Set objFwd = Nothing
End Sub
If you do not mean to forward ""there doesnt need to be anything in the body of the email."
Sub SendToAddr()
Dim objOL As Outlook.Application
Dim objItem As Object
Dim objNewMail As Outlook.MailItem
Dim strAddr As String
Set objOL = Application
On Error Resume Next
' open the item to be sure it is what you want
Set objItem = objOL.ActiveInspector.currentItem
On Error GoTo 0
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objNewMail = CreateItem(olMailItem)
objNewMail.To = anotheraddress @ somewhere.com"
objNewMail.Subject = ParseTextLinePair(objItem.body, "5.tour_booked :") & _
" " & ParseTextLinePair(objItem.body, "5.tour_price :")
objNewMail.Display
Else
MsgBox "Open a mailitem", , "SendToAddr"
End If
Else
MsgBox "Open a mailitem", , "SendToAddr"
End If
Set objOL = Nothing
Set objItem = Nothing
Set objNewMail = Nothing
End Sub
The important part provided at the link.
Function ParseTextLinePair(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
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)
End Function