Outlook VBA Auto Forward some body text as subject

[Simmons]

I have never used VBA in outlook before and have a very limited knowledge of any coding having cobbled together bits of others code in the past.

What I am looking to achieve:

We recieve an email like this:

Submitted Data

5.address1 : 23 road Road
5.address2 :
5.address3 :
5.booking_ref : A12121212
5.booking_response_charge: 0.0
5.country : United Kingdom
5.county : Merseyside
5.departure_details_airport: Manchester
5.departure_details_flightcode: FLG123
5.departure_details_flightdate: Wednesday 07 October 2015
5.email : emailaddress
5.excursions_total : 0
5.first_name : firstname
5.last_name : lastname
5.marketingbyemail : 0
5.marketingbypost : 1
5.marketingbythirdparties: 0
5.mobile : 07777777777
5.optional_extras0 :
5.phone :
5.postcode : LE2 2LE
5.source :
5.subsource :
5.title : Mr
5.total_price : 3,028.00
5.tour_booked : Name of Tour
5.tour_price : 2,999.00
5.town : Town




From this email I want to trigger another email forwarded to another address that has the subject line comprised from 2 peices of info from the body of the original (5.tour_booked + 5.tour_price) so:


Subject line: Name of Tour 2,999.00


there doesnt need to be anything in the body of the email.

I hope someone can help me?

Thanks

[skatonni]

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

[gmayor]

An alternative approach, which you can use as a script with a rule, to reply automatically as the messages arrive is as follows:

Sub AutoResponse(olItem As MailItem)
Dim sText As String
Dim sSubject As String
Dim vText As Variant, vItem As Variant
Dim i As Long
Dim olOutMail As Outlook.MailItem

    sText = olItem.Body
    vText = Split(sText, Chr(13))
    sSubject = ""
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Trim(vItem(1))
        End If
        If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Chr(32) & Trim(vItem(1))
        End If
    Next i
    Set olOutMail = Application.CreateItem(olMailItem)
    With olOutMail
        .To = "someone@somewhere.com" ' the recipient of the message
        .Subject = sSubject
        .Display 'Change to .Send after testing
    End With
lbl_Exit:
    Set olOutMail = Nothing
    Exit Sub
End Sub

Use the following to test on a message already received.

Sub TestMsg()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    AutoResponse olMsg
lbl_Exit:
    Exit Sub
End Sub

[Simmons]

Thanks so much guys, I have this working perfectly!!!

One quick follow up question:

Once the email is forwarded (to the same inbox infact) I have another rule that reads out the subject line of the email, code here:



Public Sub AnnounceMail(Item As Outlook.MailItem)
Dim currenttime As Date

currenttime = Now
Do Until currenttime + TimeValue("00:00:02") <= Now
Loop

Dim xlApp As Object

Dim strFrom As String
Dim strMessageType As String
Dim ReadOutText As String

Set xlApp = CreateObject("Excel.Application")

strFrom = Split(Item.Sender, " ")(0)
strMessageType = Right(Item.Subject, 3)


Select Case strMessageType
Case "RE:"
ReadOutText = ReadOutText & strFrom & " replied to an email regarding, " & Item.ConversationTopic
Case "FW:"
ReadOutText = ReadOutText & strFrom & " Forwarded an email regarding, " & Item.ConversationTopic
Case Else
ReadOutText = ReadOutText & Item.ConversationTopic
End Select

ReadOutText = ReadOutText & "."

xlApp.Speech.Speak ReadOutText
xlApp.Quit

Set xlApp = Nothing


End Sub



I cannot ssem to figure out how i can add this script along with the below, how do I create a second VBA script to setup with a second rule?


Thanks again

Simmons

An alternative approach, which you can use as a script with a rule, to reply automatically as the messages arrive is as follows:

Sub AutoResponse(olItem As MailItem)
Dim sText As String
Dim sSubject As String
Dim vText As Variant, vItem As Variant
Dim i As Long
Dim olOutMail As Outlook.MailItem

    sText = olItem.Body
    vText = Split(sText, Chr(13))
    sSubject = ""
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Trim(vItem(1))
        End If
        If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Chr(32) & Trim(vItem(1))
        End If
    Next i
    Set olOutMail = Application.CreateItem(olMailItem)
    With olOutMail
        .To = "EMAIL" ' the recipient of the message
        .Subject = sSubject
        .Display 'Change to .Send after testing
    End With
lbl_Exit:
    Set olOutMail = Nothing
    Exit Sub
End Sub

Use the following to test on a message already received.

Sub TestMsg()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    AutoResponse olMsg
lbl_Exit:
    Exit Sub
End Sub

[Simmons]

OK I figured out how to do 2 scripts (2 modules)

If i want to forward the email and have all the body stay as it originally was how would i do that?

Thanks

Simmons

[gmayor]

If you want to forward the mail with its text and a covering message then change as follows:

Sub AutoResponse(olItem As MailItem)
Dim olOutMail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim sText As String
Dim sSubject As String
Dim vText As Variant, vItem As Variant
Dim i As Long

    sText = olItem.Body
    vText = Split(sText, Chr(13))
    sSubject = ""
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Trim(vItem(1))
        End If
        If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Chr(32) & Trim(vItem(1))
        End If
    Next i
    Set olOutMail = olItem.Forward
    With olOutMail
        .To = "someone@somewhere.com"        ' the recipient of the message
        .Subject = sSubject
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range(0, 0)
        oRng.Text = "This is the covering message"
        .Display        'Retain this line
        '.Send 'Restore after testing
    End With
lbl_Exit:
    Set olOutMail = Nothing
    Exit Sub
End Sub

If you want to send on the message exactly as it arrived but with a different subject then

Sub AutoResponse(olItem As MailItem)
Dim sText As String
Dim sSubject As String
Dim vText As Variant, vItem As Variant
Dim i As Long

    sText = olItem.Body
    vText = Split(sText, Chr(13))
    sSubject = ""
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Trim(vItem(1))
        End If
        If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject = sSubject & Chr(32) & Trim(vItem(1))
        End If
    Next i
    Set olOutMail = Application.CreateItem(olMailItem)
    With olOutMail
        .To = "someone@somewhere.com"        ' the recipient of the message
        .Subject = sSubject
        .BodyFormat = olItem.BodyFormat
        If .BodyFormat = olFormatHTML Then
            .HTMLBody = olItem.HTMLBody
        Else
            .Body = olItem.Body
        End If
        .Display        'change to '.Send after testing
    End With
lbl_Exit:
    Set olOutMail = Nothing
    Exit Sub
End Sub

[Simmons]

Brilliant , thanks again.

I think I might have over complicated my process though.

Is there a way to read the original email and get it to read out the 2 parts that I mentioned above rather than forwarding it on in the subject? The only reason I wanted to forward it in the subject was because I had working code that would read out an emails subject.

I just want 5.tour_booked and 5.tour_price read out when an email is recieved.

Thank you again for all your help.

[gmayor]

If you simply want to read out the two items then you certainly are overthinking the process (and it would have helped had you explained exactly what you were trying to achieve in the first place). You can read the message references directly instead of forwarding it and performing a second function. You'll need a reference to the Microsoft speech object library - see my web page - and there is no need to fire up Excel to do the talking. The more difficult part is in providing the spacing that is part of the normal cadence of speech. This is easiest done by speaking the parts separately.

Option Explicit

Public Sub AnnounceMail(olItem As Outlook.MailItem)
'Set a reference to the Microsoft Speech object library
'See http://www.gmayor.com/word_text_to_speech.htm
    Dim sText As String
    Dim sSubject1 As String, sSubject2 As String
    Dim vText As Variant, vItem As Variant
    Dim i As Long
     
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject1 = "Tour booked, " & Trim(vItem(1))
        End If
    If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject2 = "Price " & Trim(vItem(1))
        End If
    Next i
    'The separation provides better expression of the texts
    SpeakText sSubject1
    SpeakText sSubject2
    
lbl_Exit:
    Exit Sub
End Sub

Private Sub SpeakText(strText As String)
Dim speech As SpVoice
    On Error Resume Next
    Set speech = New SpVoice
    speech.Speak strText, _
                 SVSFlagsAsync + SVSFPurgeBeforeSpeak
    Do
        DoEvents
    Loop Until speech.WaitUntilDone(10)
    Set speech = Nothing
End Sub

Sub TestMsg()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    AnnounceMail olMsg
lbl_Exit:
    Exit Sub
End Sub

[Simmons]

Perfect - thanks again you have be a great help!

[Simmons]

Evening,

This has proved so helpful that I have had a further request.

We have another email that is Identicle other than the fields are:

25.tour_booked : Name of Tour
25.tour_price : 2,999.00

Could the code be changed to read out if it has either of these versions?

Also if I wanted to play a sound file first and then have the info read out (sound file is 3 seconds long) would this be possible and could we delay the reading of the text until the sound has been played?

Thanks again

Simmons

[gmayor]

The code as supplied should be able to read your other message, as the strings "5.tour_booked" and "5.tour_price" that identify the lines to be read, are in the strings "25.tour_booked" and "25.tour_price".

SpeakText will read out a text string. Add an extra SpeakText line to the macro before

SpeakText sSubject1

to readout your other text. If it is some other form of 'sound file' you will have to explain what it is you want to play.

[Simmons]

Thanks gmayor,


The sound file is a sound effect of a cash register (cha-ching) so I would want the sound to play to alert me of a sale then "25.tour_booked" and "25.tour_price" to be read out after the sound has stopped playing (2 second clip) I had this working (with my code above in my 2nd post) using outlook rules to play the sound then run the script (reading out the subject line) and I added a 2 second delay to the text being read out but I cannot seem to get this working again now.


I am currently using this:


Public Sub AnnounceMail(olItem As Outlook.MailItem)
Dim sText As String
Dim sSubject1 As String, sSubject2 As String
Dim vText As Variant, vItem As Variant
Dim i As Long

sText = olItem.Body
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject1 = "Tour booked, " & Trim(vItem(1))
End If
If InStr(1, vText(i), "5.tour_price : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject2 = "Price " & Trim(vItem(1))
End If
Next i
'The separation provides better expression of the texts
SpeakText sSubject1
SpeakText sSubject2

lbl_Exit:
Exit Sub
End Sub

Private Sub SpeakText(strText As String)
Dim speech As SpVoice
On Error Resume Next
Set speech = New SpVoice
speech.Speak strText, _
SVSFlagsAsync + SVSFPurgeBeforeSpeak
Do
DoEvents
Loop Until speech.WaitUntilDone(10)
Set speech = Nothing
End Sub

Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AnnounceMail olMsg
lbl_Exit:
Exit Sub
End Sub


This reads out the 2 lines but only if the email has the 5.tour_booked if it has the 25.tour_booked nothing happens.


Thanks

Simmons

[gmayor]

The macro should work for both forms. Are you sure that your rule picks up both forms? Or you have two rules, one for each type of message, both of which call the same script? It certainly works here using the test macro and messages based on your instructions. The cash register sound you will have to provide, but assuming a WAV file enter its path where indicated. as

Const pSound As String = "C:\Path\kerching.wav"

The program will wait 2 seconds (Sleep 2000) between playing the sound and reading the texts.

Option Explicit
#If Win64 Then
    Private Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
            (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

#Else
    Private Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
                                            (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub AnnounceMail(olItem As Outlook.MailItem)
Dim sText As String
Dim sSubject1 As String, sSubject2 As String
Dim vText As Variant, vItem As Variant
Dim i As Long

Const pSound As String = "C:\Path\kerching.wav"

    sText = olItem.Body
    vText = Split(sText, Chr(13))
    For i = 1 To UBound(vText)
        If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject1 = "Tour booked, " & Trim(vItem(1))
        End If
        If InStr(1, vText(i), "5.tour_price : ") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sSubject2 = "Price " & Trim(vItem(1))
        End If
    Next i
    'The separation provides better expression of the texts
    sndPlaySound32 pSound, 0&
    DoEvents
    Sleep 2000
    SpeakText sSubject1
    SpeakText sSubject2

lbl_Exit:
    Exit Sub
End Sub

Private Sub SpeakText(strText As String)
Dim speech As SpVoice
    On Error Resume Next
    Set speech = New SpVoice
    speech.Speak strText, _
                 SVSFlagsAsync + SVSFPurgeBeforeSpeak
    Do
        DoEvents
    Loop Until speech.WaitUntilDone(10)
    Set speech = Nothing
End Sub


Sub TestMsg()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    AnnounceMail olMsg
lbl_Exit:
    Exit Sub
End Sub

[Simmons]

Hi,

thanks again and I am really sorry for keep coming back. The above was working but I then tried to get this to work with 25 as well as 5 and for some reason now what ever I do I cannot get it to worrk:

Option Explicit
#If Win64 Then
Private Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

#Else
Private Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub AnnounceMail(olItem As Outlook.MailItem)
Dim sText As String
Dim sSubject1 As String, sSubject2 As String
Dim vText As Variant, vItem As Variant
Dim i As Long

Const pSound As String = "D:\Simmons\Order.wav"

sText = olItem.Body
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject1 = "Tour booked, " & Trim(vItem(1))
End If
If InStr(1, vText(i), "5.tour_price : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject2 = "Price " & Trim(vItem(1))
End If
Next i
'The separation provides better expression of the texts
sndPlaySound32 pSound, 0&
DoEvents
Sleep 2000
SpeakText sSubject1
SpeakText sSubject2

lbl_Exit:
Exit Sub
End Sub

Private Sub SpeakText(strText As String)
Dim speech As SpVoice
On Error Resume Next
Set speech = New SpVoice
speech.Speak strText, _
SVSFlagsAsync + SVSFPurgeBeforeSpeak
Do
DoEvents
Loop Until speech.WaitUntilDone(10)
Set speech = Nothing
End Sub


Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AnnounceMail olMsg
lbl_Exit:
Exit Sub
End Sub


The above plays the correct sound then doesnt do anything else other than a normal email notification ding. I have tried creating 2 modules with another version that is identicle but with 25.'s rather than 5.'s but this didnt seem to work.

I now cannot seem to get anything to work other than the sound to play.

Thanks agina ans sorry for all this trouble.

Simmons

[Simmons]

I have attached a screenshot of how I have set this up (full code in above post) + references and below is the whole setup:

1) The attached is setup
2) I create a rule that says
2a) Message from x
2b) Move to x folder
3c) Run script


Capture.jpgCapture2.jpg


My Ideal outcome is this:

If I recieve an email from x and it has 5.tour_booked in it then move to folder x and run script 1 (with sound 1 in)
If I recieve an email from x and it has 25.tour_booked in it then move to folder x and run script 2 (with sound 2 in)

I have gone mad today trying to get this to work, I had it playing the sound and then reading the txt earler now I cannot seem to get anything working.

[gmayor]

The operative part of the code is

If InStr(1, vText(i), "5.tour_booked : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject1 = "Tour booked, " & Trim(vItem(1))
End If
If InStr(1, vText(i), "5.tour_price : ") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject2 = "Price " & Trim(vItem(1))
End If

This explicitly looks for the particular texts in the message bodies. The text must be an exact reflection of what is in the message and unique to the line of text in question. The fact that it doesn't crash, suggests that the texts are not found. As there is some scope for differences related to the number of spaces, you could use.

"5.tour_booked" and "5.tour_price"

as these are unique to the message texts and should be common to both styles of message, regardless of the spacing. If this doesn't work, the implication is that the message format is not exactly as your mock-up.

Note that the search string is case sensitive. If there is the likelihood of mixed cases then use instead:

If InStr(1, LCase(vText(i)), "5.tour_booked") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject1 = "Tour booked, " & Trim(vItem(1))
End If
If InStr(1, LCase(vText(i)), "5.tour_price") > 0 Then
vItem = Split(vText(i), Chr(58))
sSubject2 = "Price " & Trim(vItem(1))
End If

[Simmons]

Thanks all is working perfectly now. The email that we recieved had changed very slightly and so the etxt was not found.

Thanks again for all your help it is very much appreciated!

Simmons

[Simmons]

Hi,

Would it be possible to expand a little on the above? - Could I have a text box pop up with the text that is read out in it? This text box could be a web browser?

We currently have a stats dashbord on a large TV above our team that shows sales stats ideally I would want this text to show in a web browser that is always visible and showing the latest sale, so for example:

Last sale: TOURNAME & TOUR PRICE

When ever a new email is recieved and it is all read out this text would update to show the latest information.

Is this possible?

Thanks again

Simmons