I'm adapting some hMailServer code I found to MS Outlook vba. The source code is at https://www.hmailserver.com/forum/viewtopic.php?f=14&t=2960
I have tested this code in hMailServer and with Thunderbird and have it working. However, in deployment I expect I won't have access to an hMailServer, and the mail client is likely to be MS Outlook.
In the source code the author references "oMessage" but, duh, I can't determine what object "oMessage" is supposed to be, and in my adaptation causes an error in the command line string where the error is of course, "object required". Up to that point my vba script is working ok. Since the thread at hMailServer is several years old, I don't expect to get a reply on a question I posted there.
Here is the original source code:
Const g_sPHPPath = "C:\path\to\php.exe"
Const g_sScriptPath = "C:\path\to\script.php"
Const g_sPipeAddress = "something@yourdomain.com"
Sub OnDeliverMessage(oMessage)
If g_sPipeAddress = "" Then
bPipeMessage = True
Else
bPipeMessage = False
Set obRecipients = oMessage.Recipients
For i = 0 to obRecipients.Count - 1
Set obRecipient = obRecipients.Item(i)
If LCase(obRecipient.Address) = LCase(g_sPipeAddress) Then
bPipeMessage = True
End If
Next
End If
If bPipeMessage Then
sCommandLine = "cmd /c type " & g_sDQ & oMessage.Filename & g_sDQ & " | " & g_sDQ & g_sPHPPath & g_sDQ & " " & g_sDQ & g_sScriptPath & g_sDQ
Set oShell = CreateObject("WScript.Shell")
Call oShell.Run(sCommandLine, 0, TRUE)
End If
End Sub
And here is my adaptation:
Const g_sPHPPath = "C:\xampp\php\php.exe"
Const g_sScriptPath = "C:\xampp\htdocs\Recycler\test.php"
Const g_sPipeAddress = "someAddress@mail.net"
Const g_sDQ = """"
Sub OnDeliverMessage(oMessage)
Dim Explorer As Outlook.Explorer
Dim CurrentItem As Object
Set Explorer = Application.ActiveExplorer
If Explorer.Selection.Count Then
Set CurrentItem = Explorer.Selection(1)
End If
If CurrentItem.Class = olMail Then
Dim sender
sender = CurrentItem.SenderEmailAddress
End If
If g_sPipeAddress = "" Then
bPipeMessage = True
Else
If LCase(sender) = LCase(g_sPipeAddress) Then
bPipeMessage = True
End If
End If
If bPipeMessage Then
sCommandLine = "cmd /c type " & g_sDQ & oMessage.FileName & g_sDQ & " | " & g_sDQ & g_sPHPPath & g_sDQ & " " & g_sDQ & g_sScriptPath & g_sDQ
Set oShell = CreateObject("WScript.Shell")
Call oShell.Run(sCommandLine, 0, True)
End If
End Sub
So, can anyone tell me what object oMessage would equate to in the Outlook model? In the cmd string, what should I be looking for in "oMessage.FileName" ?
Did get a reply from hMailServer: "it is the filename that hmailserver creates when receiving a message (the physical .EML file) which is then streamed to clients when clients request it."
So, the argument "oMessage" is passed from hMailServer, but it is not needed in this VBA adaptation.
The solution is simply to save the email to a text file in the body of the procedure, "CurrentItem.SaveAs g_FileName, olTXT", where g_FileName is declared as a constant.
With that, the email has been piped to a text file, where it can be parsed in your language of choice. In my case, PHP where values such as "name", "store number", "phone number", etc are retrieved and saved into a MySQL database.
Finally, the rule applied in Outlook is that when the email is received, it is moved to a folder, and the OnDeliverMessage() script is called.
The revised code then is:
Const g_sPHPPath = "C:\xampp\php\php.exe"
Const g_sScriptPath = "C:\xampp\htdocs\Recycler\handler.php"
Const g_sPipeAddress = "someone@mail.net"
Const g_FileName = "C:\tmp\output.txt"
Const g_sDQ = """"
Sub OnDeliverMessage()
Dim Explorer As Outlook.Explorer
Dim CurrentItem As Object
Set Explorer = Application.ActiveExplorer
If Explorer.Selection.Count Then
Set CurrentItem = Explorer.Selection(1)
End If
CurrentItem.SaveAs g_FileName, olTXT
If CurrentItem.Class = olMail Then
Dim sender
sender = CurrentItem.SenderEmailAddress
End If
If g_sPipeAddress = "" Then
bPipeMessage = True
Else
If LCase(sender) = LCase(g_sPipeAddress) Then
bPipeMessage = True
End If
End If
If bPipeMessage Then
sCommandLine = "cmd /c type " & g_sDQ & g_FileName & g_sDQ & " | " & g_sDQ & g_sPHPPath & g_sDQ & " " & g_sDQ & g_sScriptPath & g_sDQ
Set oShell = CreateObject("WScript.Shell")
Call oShell.Run(sCommandLine, 0, True)
End If
End Sub