Forward Emails to External Email Address (Exchange/Outlook)

  • Thread starter Thread starter craig.jarchow
  • Start date Start date
C

craig.jarchow

If your work is using Microsoft Exchange like most enterprises, you'll
notice that by default it is setup so that can't create a rule in
Outlook to automatically forward emails outside of the company. This
is done for security/confidentiality reasons.

If your work doesn’t have the blackberry option or perhaps they won’t
issue you one and you happen to have a personal smart phone (Windows
Mobile, Blackberry, iPhone) and want to forward your emails there, or
perhaps you just want to forward emails to your personal account, I
have a solution for you!

I have written a Macro which forwards my incoming email automatically
bypassing the Exchange server security which prevents a rule from
doing this. I have also added some logic to only do this under the
following circumstances (so I don’t unnecessarily forward emails):
1. It is after hours (from 5pm to 9am)
2. It is during lunch (from 12pm to 1pm)
3. I am currently in a meeting

Below is the code. Simply load Visual Basic from Outlook, open the
ThisOutlookSession module and paste it in. Good luck!

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim i As Integer
Dim bSend As Boolean
Dim fwdItem As Outlook.MailItem

On Error Resume Next

bSend = False

If Hour(Now) > 17 Or Hour(Now) < 9 Then 'After hours
bSend = True
ElseIf Hour(Now) = 12 Then 'Lunch
bSend = True
ElseIf checkBusy Then 'In meeting
bSend = True
End If

If bSend Then
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem =
Application.Session.GetItemFromID(varEntryIDs(i))

Set fwdItem = objItem.Forward

fwdItem.Recipients.Add "(e-mail address removed)"
fwdItem.Send
Next
End If
End Sub

Private Function checkBusy() As Boolean
Dim olApp As Outlook.Application
Dim strFreeBusy As String
Dim pos As Integer

strFreeBusy = Application.Session.CurrentUser.freeBusy(Now,
30, True)

pos = ((Hour(Now) * 60) + Minute(Now)) / 30

If InStr(Mid(strFreeBusy, pos - 1, 3), "2") > 0 Then
checkConflict = True
Return
End If
checkConflict = False
End Function
 
I have discovered that the calendar option is not that convenient for
me, while it is working as expected, I have found a more direct
approach. As I always lock my work station when I am away for lunch,
meeting, etc. I have modified the macro to simply forward emails when
my working is locked. The approach is much simpler, however
implementation was a little tricky. Here is the code for your
reference, I hope someone else finds it as useful as I do. I credit
the checking for computer locked code to
http://gethelp.devx.com/techtips/nt_pro/10_minute_solutions/10minNT0701.asp.


Option Explicit

Private Declare Function SwitchDesktop Lib "user32" (ByVal hDesktop As
Long) As Long
Private Declare Function OpenDesktop Lib "user32" Alias
"OpenDesktopA" (ByVal lpszDesktop As String, ByVal dwFlags As Long,
ByVal fInherit As Long, ByVal dwDesiredAccess As Long) As Long
Private Declare Function CloseDesktop Lib "user32" (ByVal hDesktop As
Long) As Long
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uiAction As Long, _
ByVal uiParam As Long, _
ByRef pvParam As Any, _
ByVal fWinIni As Long) As Long

Private Const SPI_GETSCREENSAVERRUNNING As Long = 114&
Private Const DESKTOP_SWITCHDESKTOP As Long = &H100

Private Function isLocked() As Boolean

Dim p_lngHwnd As Long
Dim p_lngRtn As Long
Dim p_lngErr As Long
Dim p_lngScreenSaver As Long

isLocked = False


p_lngRtn =
SystemParametersInfo(uiAction:=SPI_GETSCREENSAVERRUNNING, _
uiParam:=0&, _
pvParam:=p_lngScreenSaver, _
fWinIni:=0&)
p_lngHwnd = OpenDesktop(lpszDesktop:="Default", dwFlags:=0,
fInherit:=False, dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)

If p_lngRtn = 0 Then
Debug.Print Now & ": Error with checking screensaver: " &
Err.LastDllError
ElseIf CBool(p_lngScreenSaver) Then
Debug.Print Now & ": Screen saver is running: " &
Err.LastDllError
isLocked = True
ElseIf p_lngHwnd = 0 Then
Debug.Print Now & ": Error with OpenDesktop: " &
Err.LastDllError
Else
p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
p_lngErr = Err.LastDllError

If p_lngRtn = 0 Then
If p_lngErr = 0 Then
Debug.Print Now & ": Desktop is locked: " &
Err.LastDllError
isLocked = True
Else
Debug.Print Now & ": Error with SwitchDesktop: " &
Err.LastDllError
End If
Else
Debug.Print Now & ": Not locked! " & p_lngRtn
End If

p_lngHwnd = CloseDesktop(p_lngHwnd)
End If
End Function

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim i As Integer
Dim bSend As Boolean
Dim fwdItem As Outlook.MailItem

On Error Resume Next

bSend = False

bSend = isLocked

If bSend Then
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem =
Application.Session.GetItemFromID(varEntryIDs(i))

Set fwdItem = objItem.Forward

fwdItem.Recipients.Add "(e-mail address removed)"
fwdItem.Send
Next
End If
End Sub
 
Can you help me with a version that only forwards an email if it is from a specific mail recipient?

Additionally, once I paste this in the ThisOutlookSession module what do I do. Do I save it as a macro? how do I make it run? How do I make it so that it always loads/runs when I open Outlook?

Thanks
 
There's an easier way to forward Exchange mail to external addresses. CodeTwo released a 3rd party tool that allows to do that in few clicks. No macros and PowerShell are needed. Read this:

Forward Exchange mail
 
Back
Top