Click here to Skip to main content
13,457,891 members
Click here to Skip to main content
Add your own
alternative version


20 bookmarked
Posted 16 Feb 2010

Forwarding Outlook emails to another account in an intelligent way

, 18 Feb 2010
Rate this:
Please Sign up or sign in to vote.
A VBS macro for Microsoft Outlook that forwards emails to another email (e.g., mobile email) while you are not in the office.


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.


Private Const FORWARD_TO_EMAIL As String = " "

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
        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) + _
        MailItem.Recipients.Add (FORWARD_TO_EMAIL)
        ' Do not keep email sent to your mobile account
        MailItem.DeleteAfterSubmit = True
        ' 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
        End If
        MailItem.Recipients.Add (originalEmailFrom)
        ' Delete email received from your mobile account
    End If
    ' Send email
    MailItem.body = strBody
    ' Set variables to null to prevent memory leaks
    Set MailItem = Nothing
    Set Recipient = Nothing
    Set objMail = Nothing
    Exit Sub
    '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
        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, _
    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
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 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!


This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)


About the Author

Software Developer (Senior)
United States United States
Born and built for Software Development. Eager to develop systems that drive business and human intelligence to the next level. Love Artificial Intelligence and have abundant experience in developing systems with a large user base. I know more than just how to write code that compiles. I can produce software that is fast, reliable, well-tested, secure, maintainable, globalizable, and on down the list of attributes of high-quality code.

You may also be interested in...

Comments and Discussions

GeneralMy vote of 5 Pin
FlytotheBluesky18-Mar-14 15:46
memberFlytotheBluesky18-Mar-14 15:46 
QuestionUpdate to VB.NET Addin Pin
Mike Fleming28-Mar-13 2:40
memberMike Fleming28-Mar-13 2:40 
QuestionAmazing stuff. But need help Pin
Chrisomamo6-Mar-13 7:10
memberChrisomamo6-Mar-13 7:10 
QuestionMessage delivery failure Pin
conkl1cp12-Oct-12 11:37
memberconkl1cp12-Oct-12 11:37 
QuestionExcellent solution! Pin
mr200126-Apr-12 6:48
membermr200126-Apr-12 6:48 
QuestionNo Script To Choose? Pin
MorriahM1-Feb-12 4:16
memberMorriahM1-Feb-12 4:16 
GeneralUpdate for Outlook 2010 64-bit? Pin
paleGreen122-Apr-11 10:52
memberpaleGreen122-Apr-11 10:52 
QuestionSent email Pin
dschotts27-Sep-10 11:06
memberdschotts27-Sep-10 11:06 
QuestionVery Nice - Can This Be Modified To Check Against a sub-folder? Pin
Inquiry12323-Aug-10 12:59
memberInquiry12323-Aug-10 12:59 
GeneralGreat Solution!!! Pin
Lone Developer17-Feb-10 5:55
memberLone Developer17-Feb-10 5:55 
AnswerRe: Great Solution!!! Pin
luis_botero19-Feb-10 4:09
memberluis_botero19-Feb-10 4:09 
GeneralIm a bit confused by ... Pin
Garth J Lancaster16-Feb-10 10:58
memberGarth J Lancaster16-Feb-10 10:58 
AnswerRe: Im a bit confused by ... [modified] Pin
luis_botero17-Feb-10 4:18
memberluis_botero17-Feb-10 4:18 

General General    News News    Suggestion Suggestion    Question Question    Bug Bug    Answer Answer    Joke Joke    Praise Praise    Rant Rant    Admin Admin   

Use Ctrl+Left/Right to switch messages, Ctrl+Up/Down to switch threads, Ctrl+Shift+Left/Right to switch pages.

Permalink | Advertise | Privacy | Terms of Use | Mobile
Web03-2016 | 2.8.180323.1 | Last Updated 18 Feb 2010
Article Copyright 2010 by luis_botero
Everything else Copyright © CodeProject, 1999-2018
Layout: fixed | fluid