Outlook VBA Script to push new mail notifications using qpush.me

outlook-push.vba

' Small Outlook-VBA script to push a new email notification to your iOS device
' using QPush (https://qpush.me/)
'
' Just install the application on your iOS device, choose a Push Name
' and place that and the generated Push Code in the section below
'
' How to add the script to Outlook?
' - Press Alt-F11 in Outlook to open Builtin VBA Editor
' - Paste this code in "ThisOutlookSession", save and exit edtior
' - Create a rule with the action "run script" and select the saved script
'
' To allow the script to be executed you have to:
' - Reduce Macro Settings security (Options -> Trust Center -> Macro Settings) to allow unsigned macros
' - Create a self cert, add the certificate to trusted certificates (in Trust Center) and sign the macro

' QPush Configuration Begin
'
' Your Device Push Name
Private Const QPushName As String = "MegaMobile"
' Your Device Push Code
Private Const QPushCode As String = "111111"
'
' QPush Configuration End



Private Const CP_UTF8 = 65001
Private Declare Function WideCharToMultiByte Lib "Kernel32" (ByVal CodePage As Long, ByVal dwflags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Sub RunTest()
    MsgBox PushNotification("john@doe.com" + vbCrLf + "ççUTF8éé")
End Sub

Sub PushNewMail(MyMail As MailItem)
    Dim strID As String
    Dim objMail As Outlook.MailItem
    
    strID = MyMail.EntryID
    Set objMail = Application.Session.GetItemFromID(strID)
    
    sHTML = PushNotification(objMail.Sender + vbCrLf + objMail.subject)
    
    Set objMail = Nothing
End Sub


Function PushNotification(msgText As String)
    'curl -s https://qpush.me/pusher/push_site/push_site/ \
    '-F name=QPUSHNAME \
    '-F code=QPUSHCODE \
    '-F sig= \
    '-F cache=false \
    '-F 'msg[text]'=msgText
    
    Const sURL As String = "https://qpush.me/pusher/push_site/push_site/"
    
    Dim oHttp As Object
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    
    oHttp.Open "POST", sURL, False
    oHttp.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    oHttp.Send ("name=" + QPushName + "&code=" + QPushCode + "&sig=&cache=false&msg[text]=" + URLEncode(msgText))
    
    PushNotification = oHttp.ResponseText
End Function

' From here on: code for URL encode - entirely taken from http://stackoverflow.com/a/3812363/432152

Public Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
    lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
    sBuffer = Space$(lLength)
    lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
    sBuffer = StrConv(sBuffer, vbUnicode)
    UTF16To8 = Left$(sBuffer, lLength - 1)
Else
    UTF16To8 = ""
End If
End Function

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False, _
   Optional UTF8Encode As Boolean = True _
) As String

    Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
    Dim StringLen As Long: StringLen = Len(StringValCopy)
    
    If StringLen > 0 Then
        ReDim result(StringLen) As String
        Dim I As Long, CharCode As Integer
        Dim Char As String, Space As String
    
      If SpaceAsPlus Then Space = "+" Else Space = "%20"
    
      For I = 1 To StringLen
        Char = Mid$(StringValCopy, I, 1)
        CharCode = Asc(Char)
        Select Case CharCode
          Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
            result(I) = Char
          Case 32
            result(I) = Space
          Case 0 To 15
            result(I) = "%0" & Hex(CharCode)
          Case Else
            result(I) = "%" & Hex(CharCode)
        End Select
      Next I
      URLEncode = Join(result, "")
    
    End If
End Function