Macro to retrieve two figures from the message body and receive a sound alert

[Jas1000]

Hi!

I know very little about VBA and macros, could you guys help me with this?

I usally receive automated emails with the same text, only two figures are different in every email. Something like this:

Price per unit: (amount 1)
Discounted price per unit: (amount 2)

What I would like the macro to do is, every time I receive an email in my inbox, check those two figures, divide (amount 1) by (amount 2) and receive a special sound alert in case the result is >1.01

To me, it sounds really complicated. What do you think?

Please, help.

[gmayor]

If the messages are consistent in format, it is really quite simple to extract the required information. Run the main 'CheckMail' macro below as a script from a rule that identifies the incoming messages. You may need to alter some of the code relating to the amounts and any currency symbol as your message showed bracketed text strings and not numbers.

The spelling of the two search strings much match EXACTLY with what is in the message.

You can play any sound you like. The macro plays a sound from Windows 10 located in the Windows\Media folder. Change it as your preference.

I have included a test macro that tests the code with a selected message from your inbox.

Option Explicit
#If Win64 Then
Public Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#Else
Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#End If

Public Sub PlayASound(ByVal pSound As String)
If Dir(pSound, vbNormal) = "" Then
pSound = Environ("WINDIR") & "\Media\" & pSound
If InStr(1, pSound, ".") = 0 Then pSound = pSound & ".wav"
If Dir(pSound, vbNormal) = vbNullString Then
Beep
Exit Sub
End If
End If
DoEvents
sndPlaySound32 pSound, 0&
DoEvents
lbl_Exit:
Exit Sub
End Sub

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

Sub CheckMail(olItem As Outlook.MailItem)
Dim sText As String
Dim vText As Variant
Dim sPrice As String, sDiscount As String
Dim i As Long
sText = Replace(olItem.Body, Chr(160), Chr(32))
vText = Split(sText, Chr(13))
On Error GoTo err_Handler
For i = 0 To UBound(vText)
If InStr(1, vText(i), "Price per unit:") > 0 Then
sPrice = Trim(Replace(vText(i), "Price per unit:", ""))
sPrice = Replace(sPrice, "(", "") 'remove the opening bracket if present
sPrice = Replace(sPrice, ")", "") 'remove the closing bracket if present
sPrice = Replace(sPrice, "€", "") 'Remove the currency symbol € if present
End If
If InStr(1, vText(i), "Discounted price per unit:") > 0 Then
sDiscount = Trim(Replace(vText(i), "Discounted price per unit:", ""))
sDiscount = Replace(sDiscount, "(", "") 'remove the opening bracket if present
sDiscount = Replace(sDiscount, ")", "") 'remove the closing bracket if present
sDiscount = Replace(sDiscount, "€", "") 'Remove the currency symbol € if present
End If
Next i
If Val(sPrice) / Val(sDiscount) > 1.01 Then
PlayASound "Alarm05" 'Choose the sound from the Windows\Media folder
End If
lbl_Exit:
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
End Sub

[Jas1000]

Hi Gmayor,

thanks for the answer!

I get the following error message:

Constants, fixed-length strings, arrays, user-defined types, and Declare statements not allowed as Public members of an object modulereferred to:


#If Win64 Then
Public Declare PtrSafe Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long


I´m running Outlook 2016, Windows 10 64.

Regards.

[gmayor]

It sounds like you put the code in the ThisOutlookSession module. You need to add an ordinary module and put the code there.

[Jas1000]

It sounds like you put the code in the ThisOutlookSession module. You need to add an ordinary module and put the code there.

Thank you Gmayor. You are right.

I´m on the right track!, because the macro works with this structure:

Price per unit: 10
Discounted price per unit: 9


However, it doesn´t work with the real structure of the message:

(Beginning of the message) TEXT (article number) 12345678 Price per unit: 312 Discounted price per unit: 298 MORE TEXT

(Rest of the message) MORE TEXT

There are no brackets or symbols in the amounts.

Do you know where the problem is?

[gmayor]

Of course it doesn't work, as it was designed to work with the originally quoted format. If the message is nothing like that why didn't you post the actual message format? :banghead:

For the revised format you need the following main part of the code. Note this will only work with the revised message format. It won't work if this is not a true representation of what you have. That being the case you shoulkd be able to work out what is required from the techniques used in the two messages.


Sub CheckMail(olItem As Outlook.MailItem)
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim sPrice As String, sDiscount As String
Dim i As Long

On Error GoTo err_Handler
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="Price per unit: ")
sPrice = oRng.Next.Words(1)
If Not IsNumeric(sPrice) Then GoTo Not_Found1
Exit Do
Loop
End With
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:="Discounted price per unit: ")
sDiscount = oRng.Next.Words(1)
If Not IsNumeric(sDiscount) Then GoTo Not_Found2
Exit Do
Loop
End With
End With

If Val(sPrice) / Val(sDiscount) > 1.01 Then
PlayASound "Alarm05" 'Choose the sound from the Windows\Media folder
End If
lbl_Exit:
Exit Sub
err_Handler:
Err.Clear
GoTo lbl_Exit
Not_Found1:
MsgBox "The price not been found. Check the message format"
GoTo lbl_Exit
Not_Found2:
MsgBox "The discounted price not been found. Check the message format"
GoTo lbl_Exit
End Sub

[Jas1000]

[QUOTE=For the revised format you need the following main part of the code. Note this will only work with the revised message format. It won't work if this is not a true representation of what you have. That being the case you shoulkd be able to work out what is required from the techniques used in the two messages.[/QUOTE]

Sorry about the message format issue, it works now.

You should run a consultancy business or something :)

Seriously, thank you very much!

Now I´m fighting to be able to sign macros, but I think I can manage myself.

[gmayor]

You should run a consultancy business or something :)
I already do! You will find instructions for signing the macros on my web site.