Click here to Skip to main content
Click here to Skip to main content

Forwarding Outlook emails to another account in an intelligent way

, 18 Feb 2010 CPOL
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.

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!

License

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

Share

About the Author

luis_botero
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.

Comments and Discussions

 
GeneralMy vote of 5 PinmemberFlytotheBluesky18-Mar-14 16:46 
QuestionUpdate to VB.NET Addin PinmemberMike Fleming28-Mar-13 3:40 
Hi, really handy this.
 
I have converted it to a VB.NET addin. This got round a problem where it would error.
 
I have also added support for attachments and replying to CC addresses.
 
I am not a developer so if someone can help develop this further that would be cool.
 
...
 

Imports System.IO
 
Public Module Module1
 

Private Const FORWARD_TO_EMAIL As String = "enter@external email here"
 
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 CC_MESSAGE_HEADER As String = "CCAgain: "
 
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
 

 

Public Sub Log(ByVal logMessage As String)
On Error Resume Next
Dim w As StreamWriter = File.AppendText("c:\log.txt")
w.Write(vbCrLf + "Log Entry : ")
w.WriteLine("{0} {1}", DateTime.Now.ToLongTimeString(), _
DateTime.Now.ToLongDateString())
w.WriteLine(" :")
w.WriteLine(" :{0}", logMessage)
w.WriteLine("-------------------------------")
w.Close()
 
End Sub
 
Sub ForwardEmail(ByVal MyMail As Outlook.MailItem)
On Error GoTo EndSub
Log("In forwarditems")
Dim strBody As String
Dim objMail As Outlook.MailItem
'Dim MailItem As Outlook.MailItem
 
Dim objOutlook As Outlook._Application
objOutlook = New Outlook.Application()
 
objMail = objOutlook.Application.Session.GetItemFromID(MyMail.EntryID)
 

 
' Initialize email to send
Dim MailItem As Outlook._MailItem
MailItem = objOutlook.CreateItem(Outlook.OlItemType.olMailItem)
 
'Copy the attachments into the new mail to be sent to the mobile device
If objMail.Attachments.Count > 0 Then
For i As Integer = 1 To objMail.Attachments.Count
Dim saveAttachment As Outlook.Attachment = objMail.Attachments(i)
objMail.Attachments(i).SaveAsFile("C:\TEMP\" & MyMail.EntryID & objMail.Attachments(i).FileName)
MailItem.Attachments.Add("C:\TEMP\" & MyMail.EntryID & objMail.Attachments(i).FileName)
Next
End If
 
MailItem.Subject = objMail.Subject
 
If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
' Only forward emails when the workstation is locked
If (Not IsWorkstationLocked()) Then
Exit Sub
End If
 
Dim cc As String = ""
For Each Recipient In objMail.Recipients
If Recipient.Type = 2 Then
cc = cc + Recipient.Address + "*"
End If
Next
 
' 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) + _
"CCAgain: " + 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
 
Log("got original from . it is : " & originalEmailFrom)
 
MailItem.Recipients.Add(originalEmailFrom)
 
Log("added originalfrom to mail")
 
Dim originalEmailCC As String
originalEmailCC = GetOriginalCCEmail(posStartHeader, posEndHeader, objMail.Body)
 
Log("got cc from mail. it is : " & originalEmailCC)
 
Dim IO As Integer
If UBound(Split(originalEmailCC, "*")) > 0 Then
For IO = 0 To UBound(Split(originalEmailCC, "*")) - 1
Dim ccrecip As Outlook.Recipient
ccrecip = MailItem.Recipients.Add(Split(originalEmailCC, "*")(IO))
ccrecip.Type = Outlook.OlMailRecipientType.olCC
Next
End If
 

'Open "c:\testcc3.txt" For Append As 5
'Print #5, originalEmailCC
'Close #5
' Delete email received from your mobile account
'objMail.Delete
End If
 
' Send email
Log("sending mail")
MailItem.Body = strBody
MailItem.Send()
 

' Set variables to null to prevent memory leaks
MailItem = Nothing
'Recipient = Nothing
objMail = Nothing
Exit Sub
 
EndSub:
'MsgBox "Unexpected error. Type: " & Err.Description
'Open "C:\file.txt" For Append As 1
'Print #1, "****Error****" + Time
'Print #1, Err.Description
'Print #1, Err.Number
'Print #1, Err.Source
 
'Close #1
End Sub
 

Private Function GetOriginalFromEmail(ByVal posStartHeader As Integer, _
ByVal posEndHeader As Integer, ByVal strBody As String) As String
On Error GoTo EndSub
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
Exit Function
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
Exit Function
EndSub:
'Open "C:\file1.txt" For Append As 1
'Print #1, Err.Description
' Print #1, Err.Number
'Close #1
End Function
 
Private Function GetOriginalCCEmail(ByVal posStartHeader As Integer, _
ByVal posEndHeader As Integer, ByVal strBody As String) As String
On Error GoTo EndSub
GetOriginalCCEmail = ""
If (posStartHeader < posEndHeader And posStartHeader > 0) Then
posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1
Dim posFrom As Integer
posFrom = InStr(posStartHeader, strBody, CC_MESSAGE_HEADER)
If (posFrom < posStartHeader) Then
Exit Function
End If
posFrom = posFrom + Len(CC_MESSAGE_HEADER)
Dim posReturn As Integer
posReturn = InStr(posFrom, strBody, Chr(13))
If (posReturn > posFrom) Then
GetOriginalCCEmail = _
Mid(strBody, posFrom, posReturn - posFrom)
End If
End If
Exit Function
EndSub:
'pen "C:\file2.txt" For Append As 1
'rint #1, Err.Description
'rint #1, Err.Number
'lose #1
End Function
 
Private Function IsWorkstationLocked() As Boolean
IsWorkstationLocked = True
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:
'Open "C:\file3.txt" For Append As 1
'Print #1, Err.Description
'Print #1, Err.Number
'Close #1
End Function
End Module
 
and the ThisAddin.vb code....
 

Public Class ThisAddIn
 
    Private Sub ThisAddIn_Startup() Handles Me.Startup
        MsgBox("Startup")
    End Sub
 
    Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
 
    End Sub
 
    Public Sub test(ByVal EntryIDCollection As String) Handles Application.NewMailEx
 
        Dim a As String = ""
        Dim b As Outlook.MailItem
        Dim oa = New Outlook.Application
        Dim c
        c = Split(EntryIDCollection, ",")
 
        For Each a In c
 
            Dim outlookns As Outlook.NameSpace
            outlookns = Application.GetNamespace("MAPI")
            b = outlookns.GetItemFromID(a)
            ForwardEmail(b)
        Next
 

    End Sub
 
End Class

QuestionAmazing stuff. But need help PinmemberChrisomamo6-Mar-13 8:10 
QuestionMessage delivery failure Pinmemberconkl1cp12-Oct-12 12:37 
QuestionExcellent solution! Pinmembermr200126-Apr-12 7:48 
QuestionNo Script To Choose? PinmemberMorriahM1-Feb-12 5:16 
GeneralUpdate for Outlook 2010 64-bit? PinmemberpaleGreen122-Apr-11 11:52 
QuestionSent email Pinmemberdschotts27-Sep-10 12:06 
QuestionVery Nice - Can This Be Modified To Check Against a sub-folder? PinmemberInquiry12323-Aug-10 13:59 
GeneralGreat Solution!!! PinmemberLone Developer17-Feb-10 6:55 

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

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

| Advertise | Privacy | Terms of Use | Mobile
Web02 | 2.8.1411022.1 | Last Updated 18 Feb 2010
Article Copyright 2010 by luis_botero
Everything else Copyright © CodeProject, 1999-2014
Layout: fixed | fluid