File: D:/hMailServer/Events/EventHandlers (prev 3).vbs
Option Explicit
' Version 1.10 (09/03/2023)
' (SS,2/9/12) added ProcessWorldPayCallbackFailure, GetAttachmentAsString, GetURL
' removed GetWebPageContents, also added SetLogFileName
' logs now saved in "D:\logs\hMailServer Events\" instead of "D:\hMailServer\Logs\eventlog.txt"
' Also added Option Explicit
' (SS,23/12/14) added Sub ProcessSpamDeletion (global rule: Spam Deletion)
' (SS,20/09/17) added Sub ProcessTransferWisePayment (hyperflight rule for transferwise emails)
' (SS,26/09/17) amended to removed oMessage.HTMLBody from email sent in Sub ProcessTransferWisePayment
' (SS,13/10/17) added removal of comma from amount in Sub ProcessTransferWisePayment
' (SS,27/10/17) added alert to Sub ProcessTransferWisePayment to mark email as alert if payment couldn't be assigned to an order
' (SS,21/10/20) Change to Sub ProcessTransferWisePayment due to slight change in format, i.e. "Amount:" changed to "Amount received:", also added reference field
' (SS,10/08/22) change to Sub ProcessTransferWisePayment to fix incorrect value in Reference field which was result on too long and causin failure when saving in PaymentInfo field in orders table
' also added Const DEBUG_MODE to help with debugging, later replaced with TRANSFERWISE_TEST_EMAIL
' (SS,09/03/23) Changes to Sub ProcessTransferWisePayment to handle new format
' Sub OnClientConnect(oClient)
' End Sub
' Sub OnAcceptMessage(oClient, oMessage)
' End Sub
' Sub OnDeliveryStart(oMessage)
' End Sub
' Sub OnDeliverMessage(oMessage)
' End Sub
' Sub OnBackupFailed(sReason)
' End Sub
' Sub OnBackupCompleted()
' End Sub
' Sub OnError(iSeverity, iCode, sSource, sDescription)
' End Sub
' Sub OnDeliveryFailed(oMessage, sRecipient, sErrorMessage)
' End Sub
' Sub OnExternalAccountDownload(oMessage, sRemoteUID)
' End Sub
' (SS,10/8/22) used to send test email to and also for detected debug mode
Const TRANSFERWISE_TEST_EMAIL = "transferwise@ssbsoft.co.uk"
' (SS,2/9/12)
Const LOG_FOLDER = "D:\logs\hMailServer Events\"
Dim NL
NL = Chr(13) + Chr(10)
Dim FLogFileName, FLogText
SetLogFileName "log.txt"
FLogText = ""
' (SS,5/10/07)
Sub ProcessGoogleCheckout(oMessage)
SetLogFileName "google-checkouts.txt" ' (SS,2/9/12)
' (SS,25/2/09) modified hmailserver rules to check for noreply@checkout.google.com in From address
' previously was "Purchase Receipt for Order" in subject
AddLog ""
' (SS,24/10/08) added & oMessage.To to show which email address / site
AddLog "1. ProcessGoogleCheckout called for " & oMessage.To
Dim NL
NL = Chr(13) + Chr(10)
' (SS,22/11/07) removed following check, wasn't working
' check email is from noreply@checkout.google.com i.e. in oMessage.FromAddress
'If oMessage.FromAddress <> "noreply@checkout.google.com" Then
' AddLog "1.1 Process aborted, reply email doesn't match noreply@checkout.google.com"
' Exit Sub
' End If
AddLog "2. Email from " & oMessage.FromAddress
' check subject contains with "Purchase Receipt for Order"
' (SS,25/2/09) removed subject check because it on longer contains 'Purchase Receipt for Order'
'If InStr(1, oMessage.Subject, "Purchase Receipt for Order", 1) = 0 Then
' AddLog "2.1 Process aborted, subject doesn't contain 'Purchase Receipt for Order'"
' Exit Sub
'End If
'AddLog "3. Email subject contains Purchase Receipt for Order"
Dim LPos, LDomain, LCallbackURL, LGoogleOrderNo, LOrderNo, LBuyer, LTotal, LEmailSubject, LBody
' NB. oMessage.Body has HTML tags removed
LGoogleOrderNo = Trim(GetString(oMessage.Subject,"Purchase Receipt for Order #", "", "A"))
' (SS,25/2/09) replaced above with following because subject now contains just the number
' (SS,16/3/09) now copes with both cases, because Google reverted back to previous template
If LGoogleOrderNo = "" Then
LGoogleOrderNo = Trim(oMessage.Subject)
End If
' (SS,16/3/09) added following to show google order no in log
AddLog "3. Email subject contains Google Order No: " & LGoogleOrderNo
' (SS,25/2/09) added following to convert newlines (0D & 0A) to spaces, the original email must be encoded
' the word Order No was being split across two lines, line ending "..Order" and next line starting with "No.."
LBody = ConvertNewlineToSpaces(oMessage.Body)
LOrderNo = Trim(GetString(LBody, "Order No GC#", " ", "A"))
' body must contain "Order No GC#"
If LOrderNo = "" Then
AddLog "3.1 Process aborted, order no missing"
Exit Sub
End If
' (SS,25/2/09) added following to detect cancellation email
If InStr(1, LBody, "Order cancelled", 1) > 0 Then
AddLog "3.2 Process aborted, order was cancelled"
Exit Sub
End If
AddLog "4. Order Number is " & LOrderNo
' (SS,25/2/09) replaced all oMessage.Body with LBody, removed NL replaced with " "
LBuyer = Trim(GetString(LBody, " has just completed a", " ", "B"))
LTotal = Trim(GetString(LBody, " Total: ", " ", "A"))
LTotal = Trim(Replace(LTotal, "=C2=A3", "")) ' remove unicode pound
' remove characters after and including the space
LPos = InStr(1, LTotal, " ", 1)
If LPos > 0 Then LTotal = Mid(LTotal, 1, LPos - 1)
LDomain = Trim(GetString(oMessage.To, "@", ">", "A"))
LCallbackURL = "http://www." & LDomain & "/googlecheckout-callback.asp"
Dim LPostData
LPostData = ""
LPostData = AddPostData(LPostData, "OrderNo", LOrderNo)
LPostData = AddPostData(LPostData, "GoogleOrderNo", LGoogleOrderNo)
LPostData = AddPostData(LPostData, "Buyer", LBuyer)
LPostData = AddPostData(LPostData, "Total", LTotal)
LPostData = AddPostData(LPostData, "EmailSubject", oMessage.Subject)
LPostData = AddPostData(LPostData, "EmailContents", oMessage.Body)
LBody = ""
LBody = LBody + "OrderNo = " & LOrderNo & NL
LBody = LBody + "GoogleOrderNo = " & LGoogleOrderNo & NL
LBody = LBody + "Buyer = " & LBuyer & NL
LBody = LBody + "Total = " & LTotal & NL
LBody = LBody + "To Address = " & oMessage.To & NL
LBody = LBody + "From Address = " & oMessage.FromAddress & NL
LBody = LBody + "Subject = " & oMessage.Subject & NL
LBody = LBody + "CallbackURL = " & LCallbackURL & NL
LBody = LBody + "Email Content = " & oMessage.Body & NL
' (SS,2/9/12) replaced GetWebPageContents(LCallbackURL, LPostData) with GetURL(LCallbackURL & "?" & LPostData)
LBody = LBody + "Callback Content = " & GetURL(LCallbackURL & "?" & LPostData)
AddLog "5. Callback executed: " & LCallbackURLBody & " - " & LPostData
' send the new email message
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
oNewMessage.From = "hMailServer (Google Checkout Event)"
oNewMessage.FromAddress = "googlecheckout@itpartnership.com"
oNewMessage.Subject = "Google Checkout Payment Received for Order " & LOrderNo
oNewMessage.AddRecipient "", oMessage.To
oNewMessage.Body = LBody
oNewMessage.Save
Set oNewMessage = Nothing
AddLog "6. Email sent"
AddLog "7. ProcessGoogleCheckout completed"
End Sub
' (SS,2/9/12)
Sub ProcessWorldPayCallbackFailure(oMessage)
SetLogFileName "worldpay-callback-failures.txt"
AddLog ""
AddLog "1. ProcessWorldPayCallbackFailure"
AddLog "2. Email to " & oMessage.To
AddLog "3. Email from " & oMessage.FromAddress
Dim LTransactionID, LCartID, LInstallationID, LCallbackURL
' NB. oMessage.Body has HTML tags removed
LTransactionID = Trim(GetString(oMessage.Body, "Transaction ID: ", NL, "A"))
LCartID = Trim(GetString(oMessage.Body, "Cart ID: ", NL, "A"))
LInstallationID = Trim(GetString(oMessage.Body, "Installation ID: ", NL, "A"))
LCallbackURL = Trim(GetString(oMessage.Body, "Callback to: ", ": ", "A"))
' (SS,16/3/09) added following to show values in log
AddLog "4. Transaction ID: " & LTransactionID
AddLog "5. Cart ID: " & LCartID
AddLog "6. Installation ID: " & LInstallationID
AddLog "7. Callback URL: " & LCallbackURL
Dim LHost, LQueryString
LHost = ""
LQueryString = ""
If oMessage.Attachments.Count > 0 Then
Dim LAttachmentString
LAttachmentString = GetAttachmentAsString(oMessage.Attachments.Item(0))
AddLog "8.1 Attachment found: " & oMessage.Attachments.Item(0).Filename
LHost = Trim(GetString(LAttachmentString, "Host: ", NL, "A"))
LQueryString = Trim(GetString(LAttachmentString, NL & NL, "", "A")) ' everything after two new lines
End if
AddLog "8.2 Host from attachment: " & LHost
AddLog "8.3 Query String from attachment: " & LQueryString
If LCallbackURL <> "" And LQueryString <> "" Then
AddLog "8.4 Attempting callback to: " & LCallbackURL & "?" & LQueryString
AddLog "8.5 Callback response = " & GetURL(LCallbackURL & "?" & LQueryString)
Else
AddLog "8.4 Nothing to do"
End If
' send email message with log
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
oNewMessage.From = "hMailServer (WorldPay Callback Failure Handler)"
oNewMessage.FromAddress = "worldpaycallbackfailure@itpartnership.com"
oNewMessage.Subject = "WorldPay Callback Failure Handled for " & LHost & " Order " & LCartID
oNewMessage.AddRecipient "", "purchases@itpartnership.com" 'oMessage.To
oNewMessage.Body = FLogText
oNewMessage.Save
Set oNewMessage = Nothing
AddLog "8. Email sent"
AddLog "9. ProcessWorldPayCallbackFailure completed"
End Sub
' (SS,5/10/07) returns part of given string after given string ending at given string
' ADirection can be "A" for after, "B" for before
' e.g. GetString("abc def ghi", "def", "h", "A") returns " g"
' e.g. GetString("abcd def ghi", "def", "bc", "B") returns "d "
' StrComp used for Text comparison to work with unicode strings
Function GetString(ASearchIn, ASearchFor, AEndsWith, ADirection)
Dim LStr, LPos, i, LLenSearchIn, LLenSearchFor, LLenEndsWith
LStr = ""
LPos = InStr(1, ASearchIn, ASearchFor, 1)
If LPos > 0 Then
LLenSearchIn = Len(ASearchIn)
LLenSearchFor = Len(ASearchFor)
LLenEndsWith = Len(AEndsWith)
If ADirection = "A" Then
LPos = LPos + LLenSearchFor
For i = LPos To LLenSearchIn
If LLenEndsWith <> 0 And StrComp(Mid(ASearchIn, i, LLenEndsWith), AEndsWith, 1) = 0 Then
Exit For
End If
LStr = LStr + Mid(ASearchIn, i, 1)
Next
Else
LPos = LPos - 1
For i = LPos To 1 Step -1
If LLenEndsWith <> 0 Then
If i - LLenEndsWith + 1 > 0 Then
If StrComp(Mid(ASearchIn, i - LLenEndsWith + 1, LLenEndsWith), AEndsWith, 1) = 0 Then
Exit For
End If
End If
End If
LStr = Mid(ASearchIn, i, 1) + LStr
Next
End If
End If
' (SS,25/2/09) added following to help with debugging
' (SS,2/9/12) removed debugged
'AddLog "GetString called with ASearchIn=" & ASearchIn & ", ASearchFor=" & ASearchFor & ", AEndsWith=" & AEndsWith & ", ADirection=" & ADirection
'AddLog "GetString returned " & LStr & ", LPos=" & LPos
GetString = LStr
End Function
' (SS,25/2/09)
Function ConvertNewlineToSpaces(AString)
ConvertNewlineToSpaces = Replace(AString, Chr(13) + Chr(10), " ")
End Function
' (SS,10/8/22)
Function ConvertNewlineToSemicolons(AString)
ConvertNewlineToSemicolons = Replace(AString, Chr(13) + Chr(10), "; ")
End Function
' (SS,5/10/07)
Function AddPostData(APostData, AFieldName, AFieldValue)
Dim LPostData
LPostData = APostData
If LPostData <> "" Then LPostData = LPostData & "&"
LPostData = LPostData & AFieldName & "=" & URLEncode(AFieldValue)
AddPostData = LPostData
End Function
' (SS/2/9/12) returns contents of given URL, used to send HTML emails, AURL can contain querystring
Function GetURL(AURL)
Dim LResult, LHttp
LResult = ""
Set LHttp = CreateObject("Msxml2.ServerXMLHTTP.3.0")
LHttp.open "GET", AURL, False
LHttp.send
If LHttp.status <> 200 then
LResult = "Error: " & LHttp.status
Else
LResult = LHttp.responseText
End If
GetURL = LResult
End Function
' (SS,5/10/07) Server.URLEncode doesn't work here (only in for ASP)
' modified to work with scripts (i.e. removed variable types and error handling code)
'**************************************
' Name: URLEncode Function
' Description:Encodes a string to create
' legally formatted
'QueryString For URL. This Function is more flexible
'than the IIS Server.Encode Function because you can
'pass In the WHOLE URL and only the QueryString data
'will be converted. IIS strangely converts EVERYTHING
'(ie "http://" becomes "http%3A%2F%2F").
' By: Markus Diersbock
'
' Inputs:sRawURL - String to Encode
'
' Returns:Encoded String
'
'This code is copyrighted and has' limited warranties.Please see http://w
' ww.Planet-Source-Code.com/vb/scripts/Sho
' wCode.asp?txtCodeId=43806&lngWId=1'for details.'**************************************
Function URLEncode(sRawURL)
Dim iLoop
Dim sRtn
Dim sTmp
Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz:/.?=_-$(){}~&"
If Len(sRawURL) > 0 Then
' Loop through each char
For iLoop = 1 To Len(sRawURL)
sTmp = Mid(sRawURL, iLoop, 1)
If InStr(1, sValidChars, sTmp, vbBinaryCompare) = 0 Then
' If not ValidChar, convert to HEX and p
' refix with %
sTmp = Hex(Asc(sTmp))
If sTmp = "20" Then
sTmp = "+"
ElseIf Len(sTmp) = 1 Then
sTmp = "%0" & sTmp
Else
sTmp = "%" & sTmp
End If
End If
sRtn = sRtn & sTmp
Next
URLEncode = sRtn
End If
End Function
Sub SetLogFileName(AFileName)
FLogFileName = LOG_FOLDER + AFileName
End Sub
' (SS,22/11/07)
Sub AddLog(AMessage)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(FLogFileName, 8, True)
f.WriteLine(Now & " - " & AMessage)
f.Close
Set f = Nothing
Set fs = Nothing
' add to log text, which may be used in email
If AMessage <> "" Then FLogText = FLogText & Now & " - " & AMessage & NL
End Sub
' (SS,2/9/12) return contents of attachment as string, it has to be saved as file first
Function GetAttachmentAsString(AAttachment)
' save to file
Dim LFileName
LFileName = LOG_FOLDER + AAttachment.Filename
AAttachment.SaveAs(LFileName)
' read from file into string
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(LFileName, 1)
GetAttachmentAsString = f.ReadAll
f.Close
Set f = Nothing
Set fs = Nothing
End Function
' (SS,23/12/14) logs from and to address of the spam email, subject and name of the attached file (added to a Rule via function)
Sub ProcessSpamDeletion(oMessage)
SetLogFileName "spam-deletion.txt"
Dim LAttachmentFilename
If oMessage.Attachments.Count > 0 Then
LAttachmentFilename = oMessage.Attachments.Item(0).Filename
Else
LAttachmentFilename = ""
End if
AddLog "ProcessSpamDeletion, " & oMessage.To & ", " & oMessage.FromAddress & ", " & oMessage.Subject & ", " & LAttachmentFilename
End Sub
' (SS,19/9/19) return contents of given file name as a string
' using this to send a test HTML email from a file (forwarding from Outlook messes up the HTML)
Function GetFileAsString(AFileName)
' read from file into string
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(AFileName, 1)
GetFileAsString = f.ReadAll
f.Close
Set f = Nothing
Set fs = Nothing
End Function
' (SS,20/9/19) writes given string to given file name
Function SaveStringAsFile(AString, AFileName)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(AFileName, 2, True)
f.Write AString
f.Close
Set f = Nothing
Set fs = Nothing
End Function
'------------------------------------------
' Following functions TrimAll, TrimChar, TrimChars and NB; moved here from dbfunctions.asp, need TrimAll
' (SS,4/6/07) the ASP Trim function only removes leading and trailing spaces
' created TrimAll which removes spaces and control characters (i.e. the same as Delphi's Trim)
' this was required because at times I also want to remove newlines and carriage returns characters
' if string is null then it's converted to a blank string ""
' (SS,23/6/09) code moved to TrimChars which handles a range of chars
' this routine now calls TrimChars for characters between 0 and 32
Function TrimAll(AString)
TrimAll = TrimChars(AString, Chr(0), Chr(32))
End Function
' (SS,23/6/09) trims given char from string
Function TrimChar(AString, ACharToTrim)
TrimChar = TrimChars(AString, ACharToTrim, ACharToTrim)
End Function
' (SS,23/6/09) trims given chars between AMinChar and AMaxChar from start and end of string
' code taken from TrimAll and modified to trim a range of chars
Function TrimChars(AString, AMinChar, AMaxChar)
Dim LString, LLen, LStart, LEnd, i
LLen = Len(AString)
LString = NB(AString)
If LString = "" Then
TrimChars = ""
Exit Function
End If
For i = 1 To LLen
If (Mid(LString, i, 1)) < AMinChar Or (Mid(LString, i, 1)) > AMaxChar Then
Exit For
End if
Next
LStart = i
LEnd = LLen
For i = LLen To 1 Step -1
If (Mid(LString, i, 1)) < AMinChar Or (Mid(LString, i, 1)) > AMaxChar Then
Exit For
End if
Next
LEnd = i
If LEnd < LStart Then
TrimChars = ""
Else
TrimChars = Mid(LString, LStart, LEnd - LStart + 1)
End If
End Function
' (SS,14/9/06) returns null as "" (i.e. Null as Blank)
Function NB(AValue)
If IsNull(AValue) Then
NB = ""
Else
' (SS,22/5/07) replaced NB = AValue with following to ensure non string is converted to a string
If VarType(AValue) = VBString Then
NB = AValue
Else
NB = CStr(AValue)
End If
End If
End Function
'------------------------------------------
' (SS,19/9/17) handles email from TransferWise to automate bank transfer payments received for HyperFlight orders
' (SS,21/10/20) fixed for change from "Amount:" to "Amount received:", also added "Reference" field
' also changed to sent alert email when amount or currency missing
' (SS,10/08/22) added code for DEBUG_MODE, also fixed issue with Reference value being correct
Sub ProcessTransferWisePayment(oMessage)
' (SS,9/3/23)
Dim VERSION
VERSION = 2
' (SS,10/8/22)
Dim DEBUG_MODE
DEBUG_MODE = InStr(oMessage.To, TRANSFERWISE_TEST_EMAIL) > 0
SetLogFileName "transferwise-payments.txt"
' (SS,25/2/09) modified hmailserver rules to check for noreply@checkout.google.com in From address
' previously was "Purchase Receipt for Order" in subject
AddLog ""
' (SS,10/8/22) if in debug mode then log that we're in this mode
If DEBUG_MODE Then
AddLog "0. In DEBUG MODE" & " (VERSION " & VERSION & ")" ' (SS,9/3/23) added version to check it's running the latest version
End If
AddLog "1. ProcessTransferWisePayment called for: " & oMessage.To
Dim NL
NL = Chr(13) + Chr(10)
AddLog "2. Email from: " & oMessage.FromAddress
' (SS,21/9/17) removed following, causing error because subject contains unicode characters
' AddLog "3. Email subject: " + oMessage.Subject
Dim LPos, LDomain, LCallbackURL, LBuyer, LTotal, LEmailSubject, LBody
' (SS,10/8/22) in debug mode get the content from a specific file, else as before
If DEBUG_MODE Then
'SaveStringAsFile LBody, "d:\temp\testfile.txt"
' when testing, I found that I had to convert the following file to ANSI format
LBody = GetFileAsString("d:\temp\transferwise-test-email.htm")
' SaveStringAsFile LBody, "d:\temp\testfile.txt"
Else
LBody = oMessage.HTMLBody
End If
' (SS,9/3/23) removed LPaymentDetails, moved to GetFromWiseBodyMethodV1
Dim LAmount, LCurrency, LPayerName, LTransferNumber, LReference
LAmount = ""
LCurrency = ""
LPayerName = ""
LTransferNumber = ""
LReference = "" ' (SS,21/10/20)
' (SS,09/03/23) moved code to GetFromWiseBodyMethodV1 (old method)
'GetFromWiseBodyMethodV1 LBody, LAmount, LPayerName, LTransferNumber, LReference
' (SS,09/03/23) V2 to handle the new format
GetFromWiseBodyMethodV2 LBody, LAmount, LPayerName, LTransferNumber, LReference
' separate currency from amount
If LAmount <> "" Then
LCurrency = Right(LAmount, 3)
LAmount = Trim(Mid(LAmount, 1, Len(LAmount) - 3))
LAmount = Replace(LAmount, ",", "") ' (SS,13/10/17) remove the comma from thousands
End If
AddLog "3. Amount: " + LAmount + " Currency: " + LCurrency
AddLog "4. Payer Name: " + LPayerName
AddLog "5. Transfer Number: " + LTransferNumber
AddLog "6. Reference: " + LReference ' (SS,10/8/22)
' (SS,21/10/20) move following here from below "If" to work for both condition in email
LBody = ""
LBody = LBody + "Amount = " & LAmount & NL
LBody = LBody + "Currency = " & LCurrency & NL
LBody = LBody + "Payer Name = " & LPayerName & NL
LBody = LBody + "Transfer Number = " & LTransferNumber & NL
LBody = LBody + "Reference = " & LReference & NL ' (SS,10/8/22)
LBody = LBody + "To Address = " & oMessage.To & NL
LBody = LBody + "From Address = " & oMessage.FromAddress & NL
LBody = LBody + "Subject = " & oMessage.Subject & NL
' exit if no amount or currency
' (SS,21/10/20) replaced Exit Sub with Else to allow alert email to be sent if no amount found
If LAmount = "" Or LCurrency = "" Then
AddLog "7. Process aborted, amount or currency missing"
' Exit Sub
' (SS,21/10/20) replaced above with following
LBody = LBody + "No callback done due to missing amount or currency" & NL
LCallbackResult = ""
Else
LDomain = Trim(GetString(oMessage.To, "@", ">", "A"))
' (SS,10/08/22) added If DEBUG_MODE Then, for different behaviour in debug mode
' (SS,09/03/23) changed debug URL from "https://hyperflight.itpartnership.com" to "https://dev.hyperflight.co.uk"
If DEBUG_MODE Then
LCallbackURL = "https://dev.hyperflight.co.uk"
Else
LCallbackURL = "https://www." & LDomain
End If
LCallbackURL = LCallbackURL & "/transferwise-callback.asp"
Dim LPostData, LCallbackResult
LPostData = ""
LPostData = AddPostData(LPostData, "Amount", LAmount)
LPostData = AddPostData(LPostData, "Currency", LCurrency)
LPostData = AddPostData(LPostData, "PayerName", LPayerName)
LPostData = AddPostData(LPostData, "TransferNumber", LTransferNumber)
LPostData = AddPostData(LPostData, "Reference", LReference) ' (SS,21/10/20)
' (SS,21/10/20) moved some of the LBody code from here to above
LBody = LBody + "Callback URL = " & LCallbackURL & NL
LCallbackResult = GetURL(LCallbackURL & "?" & LPostData)
LBody = LBody + "Callback Response = " & NL & LCallbackResult & NL
' (SS,26/9/17) removed following and renamed "Callback Content" to "Callback Response" above, also removed
'LBody = LBody + "Email Content = " & NL & NL & oMessage.HTMLBody
' (SS,10/8/22) added ConvertNewlineToSemicolons to following, to keep all text on same line
AddLog "7. Callback executed and returned: " & ConvertNewlineToSemicolons(LCallbackResult)
End If
' send the new email message
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
oNewMessage.From = "hMailServer (TransferWise Payment Event)"
oNewMessage.FromAddress = "transferwise@itpartnership.com"
' (SS,27/10/17) added following if, to mark as "ALERT!!!" if payment couldn't be applied
Dim LSubject
LSubject = "TransferWise Payment Received (" & LTransferNumber & ")"
If InStr(LCallbackResult, "Payment succesfully applied") = 0 Then
LSubject = "ALERT!!! " + LSubject
oNewMessage.HeaderValue("X-Priority") = "1" ' mark as high importance
End If
oNewMessage.Subject = LSubject
' (SS,10/8/22) added If Not DEBUG_MODE Then to only send to this address in live mode
If Not DEBUG_MODE Then
oNewMessage.AddRecipient "", "neil@hyperflight.co.uk" ' (SS,21/9/17) oMessage.To doesn't work because it contains name as well
End If
oNewMessage.AddRecipient "", "contactforms@itpartnership.com"
oNewMessage.Body = LBody
oNewMessage.Save
Set oNewMessage = Nothing
AddLog "8. Email sent"
AddLog "9. ProcessTransferWisePayment completed"
End Sub
' (SS,9/3/23) code moved here from ProcessTransferWisePayment above, L prefix changed to A prefix for variable name
Sub GetFromWiseBodyMethodV1(ABody, ByRef AAmount, ByRef APayerName, ByRef ATransferNumber, ByRef AReference)
Dim LPaymentDetails
' try email format for EUR payments
LPaymentDetails = Trim(GetString(ABody, "Payment details</h5>", "</dl>", "A"))
If LPaymentDetails <> "" Then
' LAmount = Trim(GetString(LPaymentDetails, "<dt>Amount:</dt>", "</dd>", "A"))
' (SS,21/10/20) replaced "Amount:" with "Amount received:", it had stopped working, last worked 13/10/2020
AAmount = Trim(GetString(LPaymentDetails, "<dt>Amount received:</dt>", "</dd>", "A"))
AAmount = Trim(GetString(AAmount, "<dd>", "</dd>", "A"))
APayerName = Trim(GetString(LPaymentDetails, "<dt>From:</dt>", "</dd>", "A"))
APayerName = Trim(GetString(APayerName, "<dd>", "</dd>", "A"))
ATransferNumber = Trim(GetString(LPaymentDetails, "<dt>Transfer Number:</dt>", "</dd>", "A"))
ATransferNumber = Trim(GetString(ATransferNumber, "<dd>", "</dd>", "A"))
' (SS,21/10/20) noticed they now have the reference field, now added
'LReference = Trim(GetString(LPaymentDetails, "<dt>Reference:</dt>", "</dd>", "A"))
' (SS,10/8/22) replaced above with following to fix issue
AReference = Trim(GetString(LPaymentDetails, "<dt>Reference:</dt>", "</dd>", "A"))
AReference = Trim(GetString(AReference, "<dd>", "</dd>", "A"))
Else
' try email format for USD payments
LPaymentDetails = Trim(GetString(ABody, "<strong>Amount:</strong>", "</tbody>", "A"))
AAmount = TrimAll(GetString(LPaymentDetails, "-webkit-text-size-adjust:100%;"">", "</td>", "A"))
APayerName = Trim(GetString(LPaymentDetails, "<strong>From:</strong>", "</tr>", "A"))
APayerName = TrimAll(GetString(APayerName, "-webkit-text-size-adjust:100%;"">", "</td>", "A"))
ATransferNumber = Trim(GetString(LPaymentDetails, "<strong>Transfer Number:</strong>", "</tr>", "A"))
ATransferNumber = TrimAll(GetString(ATransferNumber, "-webkit-text-size-adjust:100%;"">", "</td>", "A"))
End If
End Sub
' (SS,9/3/23) V2 for new format
Sub GetFromWiseBodyMethodV2(ABody, ByRef AAmount, ByRef APayerName, ByRef ATransferNumber, ByRef AReference)
Dim LPaymentDetails
LPaymentDetails = Trim(GetString(ABody, "Payment details</div>", "</table>", "A"))
AAmount = Trim(GetString(LPaymentDetails, ">Amount received:</div>", ">Reference:</div>", "A"))
AAmount = Trim(GetString(AAmount, "</div>", ">", "B"))
APayerName = Trim(GetString(LPaymentDetails, ">From:</div>", ">Amount received:</div>", "A"))
APayerName = Trim(GetString(APayerName, "</div>", ">", "B"))
ATransferNumber = Trim(GetString(LPaymentDetails, ">Transfer Number:</div>", "</tbody>", "A"))
ATransferNumber = Trim(GetString(ATransferNumber, "</div>", ">", "B"))
AReference = Trim(GetString(LPaymentDetails, ">Reference:</div>", ">Transfer Number:</div>", "A"))
AReference = Trim(GetString(AReference, "</div>", ">", "B"))
End Sub
' (SS,10/8/22) following is used for testing Sub ProcessTransferWisePayment
Sub SendTestEmail(oMessage)
Dim LBody
'LBody = GetFileAsString("D:\Temp\testemail.txt")
LBody = GetFileAsString("D:\Temp\transferwise-test-email.htm")
'SendEmail "Surinder", "transferwise@ssbsoft.co.uk", "hMailServer SendTestEmail Event", "hmailserver@itpartnership.com", "Just testing", LBody, True
' (SS,10/8/22) replaced above with following
SendEmail "TransferWise Test", TRANSFERWISE_TEST_EMAIL, "hMailServer SendTestEmail Event", "hmailserver@itpartnership.com", "Just testing TransferWise", LBody, True
AddLog "SendTestEmail called. Debug Mode: " & DEBUG_MODE ' (SS,10/8/22)
End Sub
' (SS,19/9/17) send given email
Sub SendEmail(AToName, AToAddress, AFromName, AFromAddress, ASubject, ABody, AIsHTML)
Dim oNewMessage
Set oNewMessage = CreateObject("hMailServer.Message")
' (SS,10/8/22) added & "<" & AFromAddress & ">" because address was not appearing in the "From" field in an email
' later reverted back, don't need a reply address because it's not applicable
' oNewMessage.From = AFromName & "<" & AFromAddress & ">"
oNewMessage.From = AFromName
oNewMessage.FromAddress = AFromAddress
oNewMessage.Subject = ASubject
oNewMessage.AddRecipient AToName, AToAddress
If AIsHTML Then
oNewMessage.HTMLBody = ABody
Else
oNewMessage.Body = ABody
End If
oNewMessage.Save
Set oNewMessage = Nothing
End Sub