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)
Set MailItem = Application.CreateItem(olMailItem)
MailItem.Subject = objMail.Subject
If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
If (Not IsWorkstationLocked()) Then
Return
End If
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)
MailItem.DeleteAfterSubmit = True
Else
strBody = objMail.body
Dim posStartHeader As Integer
posStartHeader = InStr(strBody, START_MESSAGE_HEADER)
Dim posEndHeader As Integer
posEndHeader = InStr(strBody, END_MESSAGE_HEADER)
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)
objMail.Delete
End If
MailItem.body = strBody
MailItem.Send
Set MailItem = Nothing
Set Recipient = Nothing
Set objMail = Nothing
Exit Sub
EndSub:
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:
- Create a certificate so that your macro runs without warnings
- Go to: Start > All Programs > Microsoft Office > Microsoft Office Tools > Digital Certificate for VBA Projects
- Type a name of a certificate, e.g.: MyOutlookMacro
- Click OK
- Open Microsoft Outlook
- Go to Tools / Macro / Visual Basic Editor
- Copy the code above and paste it inside the VB editor
- Replace your_email@your_domain.com by the email to which you want to forward your Inbox emails in Outlook
- Save it
- Click on Tools > Digital Signature
- Click on [Choose] and select the certificate you created in step 1
- Click OK, then click the Save button and close the Visual Basic Editor
- From Outlook, click on Tools / Rules and Alerts
- Click on New Rule
- Select <Check messages when they arrive>
- Click [Next], then a window will pop up asking if you want to apply this rule to every message you receive, click [Yes]
- On Select Action, check [run a script]
- Then, click on a script and select the macro we just created
- Click [Finish]
- You are set!