Forwarding Outlook emails to another account in an intelligent way

Introduction

I was looking for a tool or a way to be notified on my mobile phone about any new emails I get in my work computer. I only wanted to be notified when I wasn't in the office, so I wrote a VBA macro for Outlook to do the trick. What the macro does is to check if the computer is locked, which means you are not in the office or desk, then it'll compose a new email and send it to your other email. Additionally, this macro also allows you to reply from your mobile account, then when the code in the Outlook macro detects the email comes from your mobile email, it automatically forwards it to whoever sent it originally, stripping out any control text inserted before.

Code

Private Const FORWARD_TO_EMAIL As String = "your_email@your_domain.com "

Private Const START_MESSAGE_HEADER As String = "--------StartMessageHeader--------"
Private Const END_MESSAGE_HEADER As String = "--------EndMessageHeader--------"
Private Const FROM_MESSAGE_HEADER As String = "From: "

Private Const DESKTOP_SWITCHDESKTOP As Long = &H100
Private Declare Sub LockWorkStation Lib "User32.dll" ()
Private Declare Function SwitchDesktop Lib "user32" _
    (ByVal hDesktop As Long) As Long
Private Declare Function OpenDesktop _
    Lib "user32" Alias "OpenDesktopA" _
    (ByVal lpszDesktop As Any, _
    ByVal dwFlags As Long, _
    ByVal fInherit As Long, _
    ByVal dwDesiredAccess As Long) As Long
    
Sub ForwardEmail(MyMail As MailItem)
    On Error GoTo EndSub
    
    Dim strBody As String
    Dim objMail As Outlook.MailItem
    Dim MailItem As Outlook.MailItem
       
    Set objMail = Application.Session.GetItemFromID(MyMail.EntryID)
    
    ' Initialize email to send
    Set MailItem = Application.CreateItem(olMailItem)
    MailItem.Subject = objMail.Subject
    
    If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
        ' Only forward emails when the workstation is locked
        If (Not IsWorkstationLocked()) Then
            Return
        End If
    
        ' Compose email and send it to your other email
        strBody = START_MESSAGE_HEADER + Chr$(13) + _
            FROM_MESSAGE_HEADER + objMail.SenderEmailAddress + Chr$(13) + _
            "Name: " + objMail.SenderName + Chr$(13) + _
            "To: " + objMail.To + Chr$(13) + _
            "CC: " + objMail.CC + Chr$(13) + _
            END_MESSAGE_HEADER + Chr$(13) + Chr$(13) + _
            objMail.body
        MailItem.Recipients.Add (FORWARD_TO_EMAIL)
        
        ' Do not keep email sent to your mobile account
        MailItem.DeleteAfterSubmit = True
    Else
        ' Parse the original mesage and reply to the sender
        strBody = objMail.body
        Dim posStartHeader As Integer
        posStartHeader = InStr(strBody, START_MESSAGE_HEADER)
        Dim posEndHeader As Integer
        posEndHeader = InStr(strBody, END_MESSAGE_HEADER)
        
        'Remove the message header from the body
        strBody = Mid(strBody, 1, posStartHeader - 1) + _
            Mid(strBody, posEndHeader + Len(END_MESSAGE_HEADER) + 4)

        Dim originalEmailFrom As String
        originalEmailFrom = GetOriginalFromEmail(posStartHeader, _
                                                 posEndHeader, objMail.body)
        If (originalEmailFrom = "") Then
            Return
        End If
        
        MailItem.Recipients.Add (originalEmailFrom)
        
        ' Delete email received from your mobile account
        objMail.Delete
    End If
    
    ' Send email
    MailItem.body = strBody
    MailItem.Send
    
    
    ' Set variables to null to prevent memory leaks
    Set MailItem = Nothing
    Set Recipient = Nothing
    Set objMail = Nothing
    Exit Sub
    
EndSub:
    'MsgBox "Unexpected error. Type: " & Err.Description
End Sub


Private Function GetOriginalFromEmail(posStartHeader As Integer, _
        posEndHeader As Integer, strBody As String) As String
    GetOriginalFromEmail = ""
    If (posStartHeader < posEndHeader And posStartHeader > 0) Then
        posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1
        Dim posFrom As Integer
        posFrom = InStr(posStartHeader, strBody, FROM_MESSAGE_HEADER)
        If (posFrom < posStartHeader) Then
            Return
        End If
        posFrom = posFrom + Len(FROM_MESSAGE_HEADER)
        Dim posReturn As Integer
        posReturn = InStr(posFrom, strBody, Chr$(13))
        If (posReturn > posFrom) Then
            GetOriginalFromEmail = _
                Mid(strBody, posFrom, posReturn - posFrom)
        End If
    End If
End Function

Private Function IsWorkstationLocked() As Boolean
    IsWorkstationLocked = False
    On Error GoTo EndFunction

    Dim p_lngHwnd As Long
    Dim p_lngRtn As Long
    Dim p_lngErr As Long
    
    p_lngHwnd = OpenDesktop(lpszDesktop:="Default", _
        dwFlags:=0, _
        fInherit:=False, _
        dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)
    
    If p_lngHwnd <> 0 Then
        p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
        p_lngErr = Err.LastDllError
        
        If p_lngRtn = 0 Then
            If p_lngErr = 0 Then
                IsWorkstationLocked = True
            End If
        End If
    End If
EndFunction:
End Function

Using the code

Here's what you need to do to install and use this macro:

1. Create a certificate so that your macro runs without warnings
1. Go to: Start > All Programs > Microsoft Office > Microsoft Office Tools > Digital Certificate for VBA Projects
2. Type a name of a certificate, e.g.: MyOutlookMacro
3. Click OK
2. Open Microsoft Outlook
3. Go to Tools / Macro / Visual Basic Editor
4. Copy the code above and paste it inside the VB editor
5. Replace your_email@your_domain.com by the email to which you want to forward your Inbox emails in Outlook
6. Save it
7. Click on Tools > Digital Signature
8. Click on [Choose] and select the certificate you created in step 1
9. Click OK, then click the Save button and close the Visual Basic Editor
10. From Outlook, click on Tools / Rules and Alerts
11. Click on New Rule
12. Select <Check messages when they arrive>
13. Click [Next], then a window will pop up asking if you want to apply this rule to every message you receive, click [Yes]
14. On Select Action, check [run a script]
15. Then, click on a script and select the macro we just created
16. Click [Finish]
17. You are set!