Forward Emails to External Email Address (Exchange/Outlook)

[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

 

[craig.jarchow]

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

 

[JM5555]

Hi Craig,

That is superb, exactly what i need, except I can't get it to work :-(

(i need everything apart from it redirecting mail during the lunch hour)

Can you help?

Am a bit of a noobie, so could do with explicit instructions? ;-)

FYI - My exchange server has the setting set to not allow automatic forwarding

Also, will the forwarding work if outlook is not open?

Many thanks for your help with this, your the only person i can find who
understands the problem!

My email is (e-mail address removed)

Many thanks

James