Forward emails to external address during specific time period

Posted on 2008-10-10
Medium Priority
Last Modified: 2013-11-10
I have a user who wants to forward emails to an external email account during non business hours.  I have seen a vb script by BlueDevilFan that looks like it will work with a little modification.  Unfortunately, my vb is too weak to do the modifications myself.  Any help would be appreciated.

Times to forward emails are 5PM to 8AM.

From BlueDevilFan

Here's a VBA script, a macro, that'll do exactly what you've described.  To use it:
1.  Start Outlook
2.  Click Tools->Macro->Visual Basic Editor
3.  If not already expanded, expand Microsoft Outlook Objects in the Project pane, then click on ThisOutlookSession
4.  Copy the script below
5.  Paste the script into the right-hand pane of the VB Editor
6.  Edit the script making the changes as per the comments I included in the code
7.  Click the diskette icon on the toolbar to save the changes
8.  Close the VB Editor
9.  Click Tools->Macro->Security
10.  Set Security Level to Medium
11.  Close Outlook
12.  Start Outlook
13.  A dialog-box will appear telling you the ThisOutlookSession contains macros and asking if you want to enable them.  Say yes.
14.  Test the macro
15.  When the macro runs Outlook will present you with another dialog-box advising that a program is trying to access your mailbox and asking if you want to allow it to.  Say yes.
16.  If a message from the designated user, with the specified subject is in the mailbox, and if the time is currently between 9:00am and 5:00pm, then the message will be moved to the destination folder.  Otherwise, nothing will happen.
17.  Once you've verified that the macro works as expected, then you need to sign the macro to avoid having Outlook security warn you wach time the macro runs.  Here's a link to instructions on exactly how to go about doing that: http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnoxpta/html/odc_dsvba.asp

'Script begins here
Private WithEvents objInboxItems As Items

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.GetNamespace("MAPI")
    ' instantiate Items collections for folders we want to monitor
    Set objInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    Set objNS = Nothing
End Sub

Private Sub Application_Quit()
    ' disassociate global objects declared WithEvents
    Set objInboxItems = Nothing
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim olItems As Items, _
        olItem As Object, _
        olMailItem As MailItem, _
        olAttachmentItem As Attachment, _
        olDestinationFolder As Outlook.MAPIFolder, _
        bolSenderMatch As Boolean, _
        bolSubjectMatch As Boolean, _
        bolTimeMatch As Boolean
    'Change the MAPI folder path on the next line to that of your destination folder
    Set olDestinationFolder = OpenMAPIFolder("\eeBlueDevilFan\eeTesting")
    Set olItems = objInboxItems.Restrict("[Unread] = True")
    For Each olItem In olItems
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            'Change the sender's name on the next line to the sender you want to key on
            bolSenderMatch = (olMailItem.SenderName = "eeBlueDevilFan")
            'Change eeTesting on the next line to the subject you want to key on
            bolSubjectMatch = (InStr(1, olMailItem.Subject, "eeTesting", vbTextCompare) > 0)
            'Change the times on the next line to those you want to use
            bolTimeMatch = (Time >= #9:00:00 AM#) And (Time <= #5:00:00 PM#)
            If bolSenderMatch And bolSubjectMatch And bolTimeMatch Then
                olMailItem.Move olDestinationFolder
            End If
        End If
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function
'Script ends here
Question by:RSmura
  • 5
  • 4
LVL 23

Expert Comment

by:Stacy Spear
ID: 22693748
The first question to ask before even looking at the script is if allow automatic forwarding is turned on for your organization?
LVL 76

Accepted Solution

David Lee earned 500 total points
ID: 22693903
Hi, RSmura.

I've modified the essential portion of the script to forward all messages that arrive after 5:00 PM and before 8:00 AM.  Replace the objInboxItems_ItemAdd subroutine from the original script with the one below.  The rest of the script remains unchanged.

Keep in mind that Outlook has to be open and running for this script to work.  It cannot do its job otherwise.

darkstar3d, I don't think that automatic forwarding has any bearing here.  Items sent via scripting are indistinguishable from an item sent by a user.  I believe the automatic forwarding setting applies to rules and the Out of Office function.  Outlook/Exchange knows that those are automatic processes.  They don't know if a script is being run via an event trigger, as in this case, or if it's being run manually by the user.
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim olkMailItem As Outlook.MailItem, _
        olkForward As Outlook.MailItem, _
        bolTimeMatch As Boolean
        If Item.Class = olMail Then
            Set olkMailItem = Item
            'Change the times on the next line to those you want to use'
            bolTimeMatch = (Time >= #5:00:00 PM#) Or (Time <= #8:00:00 AM#)
            If bolTimeMatch Then
                Set olkForward = olkMailItem.Forward
                'Change the email address on the following line'
                olkForward.Recipients.Add "someone@somewhere.com"
            End If
        End If
    Set olkMailItem = Nothing
    Set olkForward = Nothing
End Sub

Open in new window


Author Comment

ID: 22701610
darkstar3d, BlueDevilFan is correct.  That feature is only for automatically generated emails, not for ones generated by users or scripts (which look like they were generated by the user to the server).  Secondly, the answer to that question does not preclude you from offering a solution, but simply pointing out that your solution might be dependent on that particular setting.

BlueDevilFan, I'll try the script and let you know later today.  Thanks for the suggested changes to your script.
Simplify Active Directory Administration

Administration of Active Directory does not have to be hard.  Too often what should be a simple task is made more difficult than it needs to be.The solution?  Hyena from SystemTools Software.  With ease-of-use as well as powerful importing and bulk updating capabilities.


Author Comment

ID: 22757753
BDF, code works great with one modification.  The NEXT on line 16 of your code needs to be removed as there is no FOR statement before it.

I will absolutely accept this code as SOLVES THE PROBLEM.  I do however, have two additional requests.  Is there a way to execute the script so that the does NOT appear as a forwarded message in the inbox?  Second, is there a way to forward ALL emails when OOF is enabled?

Thanks much BDF!  Appreciate the code!
LVL 76

Expert Comment

by:David Lee
ID: 22763614
"does NOT appear as a forwarded message in the inbox"
Meaning that you don't want the "FW:" on the subject line or ...?

"Second, is there a way to forward ALL emails when OOF is enabled?"
So long as Outlook is running, yes.  It's not possible to do that via scripting if Outlook is not running.

Author Comment

ID: 22766367
The message should not appear to be forwarded in the mailbox, not simply the FW removed from the subject line.

My impression was that Outlook had to be running all the time for the script to function.
LVL 76

Expert Comment

by:David Lee
ID: 22766666
Well, it's impossible to forward without the item appearing as forward.  The only alternative is to create a new message, copy and paste the body from the received message along with any attachments, and send it on.  The problem with this is that it'll lose the original sender information along with the date and time, etc.

Author Comment

ID: 22766704
I agree.

I also just realized he can create a RULE under OOF that will forward his emails while OOF is on.  That covers everything.  Thanks much for the assistance!

Author Closing Comment

ID: 31508243
Thanks again for the help.  Really appreciate the code.
LVL 76

Expert Comment

by:David Lee
ID: 22767303
You're welcome.  Glad I could help out.

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Microsoft Jet database engine errors can crop up out of nowhere to disrupt the working of the Exchange server. Decoding why a particular error occurs goes a long way in determining the right solution for it.
This video demonstrates how to sync Microsoft Exchange Public Folders with smartphones using CodeTwo Exchange Sync and Exchange ActiveSync. To learn more about CodeTwo Exchange Sync and download the free trial, go to: http://www.codetwo.com/excha…
This video shows how to quickly and easily add an email signature for all users on Exchange 2016. The resulting signature is applied on a server level by Exchange Online. The email signature template has been downloaded from: www.mail-signatures…
Suggested Courses

621 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question