Forward all incoming emails

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, and 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 contain 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 is received in the mailbox, and if the time is currently between the times you set, then the message will be forwarded to the designated email address.  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 each time the macro runs.  

A VBA script, a macro that will forward emails received in your Outlook Inbox to an external email address
'Coding
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, _
        bolTimeMatch As Boolean
    Set olItems = objInboxItems.Restrict("[Unread] = True")
    For Each olItem In olItems
        If olItem.Class = olMail Then
            Set olMailItem = olItem

            'Change the times here
            bolTimeMatch = (Time >= #4:00:00 PM#) And (Time <= #8:30:00 AM#)
            If bolTimeMatch Then
                Dim objMail As Outlook.MailItem
                Set objItem = olMailItem
                Set objMail = objItem.Forward

'Put your email address to forward
                objMail.To = abc@gmail.com"
                objMail.Send
                Set objItem = Nothing
                Set objMail = Nothing
            End If
        End If
    Next
End Sub
Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function

I'd do it a bit differently.  I'd create a rule that fires for all new messages and set that rule to run the following macro.

Sub AutoForwardMessages(Item As Outlook.MailItem)
    'On the next line, edit the time forwarding is to begin
    Const TIME_BEG = #7:00:00 PM#
    'On the next line, edit the time that forwarding is to end
    Const TIME_END = #5:00:00 AM#
    'On the next line, edit the address that messages are to be forwarded to
    Const ACCT_ADDR = "someone@gmail.com"
    Dim olkFwd As Outlook.MailItem
    If (Time >= TIME_BEG) And (Time <= TIME_END) Then
        Set olkFwd = Item.Forward
        olkFwd.To = ACCT_ADDR
        olkFwd.Send
    End If
    Set olkFwd = Nothing
End Sub

Select allOpen in new window

Hello,

Pratik,
the script is not forwarding the emaisl,
I'm only receiving the original email.
I tried with a gmail account, pop3 account, both.

BlueDevilFan
is there anyway I can run your script without creating a rule?

thanks again,

As a test or as a permanent solution?  If it's the former, then yes.  Add this code to what you already have, then select a message and run TestAFM.  If it's the latter, then that's possible too, but will require more code.  The rule is a simpler and more flexible solution.

Sub TestAFM()
    AutoForwardMessages Application.ActiveExplorer.Selection(1)
End Sub

Select allOpen in new window

it will be permanent,
I will be using the script on about 20 - 30 computers.

I appreciate your time and help,

Ok.  Use this version instead.  This code must go in the ThisOutlookSession module.

Dim WithEvents olkApp As Outlook.Application

Private Sub Application_Startup()
    Set olkApp = Application
End Sub

Private Sub Application_Quit()
    Set olkApp = Nothing
End Sub

Private Sub olkApp_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection, ",")
    For Each varEID In arrEID
        Set olkItm = Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            AutoForwardMessages olkItm
        End If
    Next
    Set olkItm = Nothing
End Sub

Sub AutoForwardMessages(Item As Outlook.MailItem)
    'On the next line, edit the time forwarding is to begin
    Const TIME_BEG = #7:00:00 PM#
    'On the next line, edit the time that forwarding is to end
    Const TIME_END = #5:00:00 AM#
    'On the next line, edit the address that messages are to be forwarded to
    Const ACCT_ADDR = "someone@gmail.com"
    Dim olkFwd As Outlook.MailItem
    If (Time >= TIME_BEG) And (Time <= TIME_END) Then
        Set olkFwd = Item.Forward
        olkFwd.To = ACCT_ADDR
        olkFwd.Send
    End If
    Set olkFwd = Nothing
End Sub                                       

Select allOpen in new window

Hello,
it's not forwarding the emails.

I tried with xxxxxxxxxx@gmail.com
I tried with pop3   wasiim@xxxxxxxxxxxxx.com

thank you

ok, ignore my last message,
I just had to restart outlook for some reason,
it's working.

I wil ldo a second test.

thank you .

Hello BlueDevilFan
sorry, but it's not forwarding.
I received 30+  emails in the last hour, none was forwarded.

I don't get any errors.

I thought I got it working when I restarted outlook, but it was an original email forwarded from another email.

thanks,

is it between 7:00pm and 5:00am where you are?

I changed the time (for my testing)
    Const TIME_BEG = #2:00:00 PM#
    Const TIME_END = #3:59:59 PM#

thanks again,

What is macro security set to?

No Security check for Macros.

Depending up on complexity the rules, and if you are running and can access Exchange, I'd look at the task scheduler and PowerShell script the rules.  Any dependence ThisOutlookSession leaves you vulnerable to all the myriad reasons that Outlook on a particular machine may be shutdown (user brain death, brownout, Outlook crash, Patch Tuesday etc.)  or not working (offline, send and receive switched to manual and what have you.)  The rules can be scripted to run at Exchange.
http://www.msexchange.org/articles-tutorials/exchange-server-2010/management-administration/managing-inbox-rules-exchange-server-2010.html
and then scheduled
http://www.msexchange.org/kbase/ExchangeServerTips/ExchangeServer2013/Powershell/scheduling-exchange-powershell-task.html
After that, they are applied at Exchange, and not each individual's Outlook.  You then have a central spot to manage and maintain them, and don't have a hassle when users, move, leave, change or upgrade machines.
It's more work initially, and a learning curve if you don't know PowerShell -- but PowerShell is with us for the long haul, and you will have a more robust solution in the end.

That's my 2 cents, anyway

Replace the code you have now with the version below.  Close and restart Outlook.  Let me know what happens when a message arrives.

Dim WithEvents olkApp As Outlook.Application

Private Sub Application_Startup()
    Set olkApp = Application
End Sub

Private Sub Application_Quit()
    Set olkApp = Nothing
End Sub

Private Sub olkApp_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection, ",")
    MsgBox "NewMailEx fired"
    For Each varEID In arrEID
        Set olkItm = Session.GetItemFromID(varEID)
        If olkItm.Class = olMail Then
            AutoForwardMessages olkItm
        End If
    Next
    Set olkItm = Nothing
End Sub

Sub AutoForwardMessages(Item As Outlook.MailItem)
    'On the next line, edit the time forwarding is to begin
    Const TIME_BEG = #7:00:00 PM#
    'On the next line, edit the time that forwarding is to end
    Const TIME_END = #5:00:00 AM#
    'On the next line, edit the address that messages are to be forwarded to
    Const ACCT_ADDR = "someone@gmail.com"
    Dim olkFwd As Outlook.MailItem
    MsgBox "AutoForwardMessages fired"
    If (Time >= TIME_BEG) And (Time <= TIME_END) Then
        Set olkFwd = Item.Forward
        olkFwd.To = ACCT_ADDR
        olkFwd.Send
    End If
    Set olkFwd = Nothing
End Sub                                       

Select allOpen in new window

Hello,
I get 2 message boxes

NewMailEx Fired --- > OK
Auto Autoforward Messages Fired --- > OK

But I only received one email.

thanks

That's fine. It proves the code is running. Are you sure you  adjusted the time correctly ?

Hello,
yes, I changed the time to different times (Time now is 8:22PM --- Eastern Time), still no forward.

it's a little awkward, I only got the message boxes once, and now when I try again I don't get the pop up boxes.
NewMailEx Fired --- > OK
Auto Autoforward Messages Fired --- > OK

I restarted Outlook, still no pop ups windows.

I even took the time constraints out, no pop ups windows, no Forward.

thank you

If you aren't getting pop-ups, then the code isn't running at all. Are you familiar with the debugger?

not really, (Sorry)
I have a vbs debugger on one of the laptops,
if I run the debugger on the code,

I get

Microsoft (R) Windows Script Host Version 5.8
Copyright (C) Microsoft Corporation. All rights reserved.

C:\Users\Wassim\AppData\Local\Adersoft\VbsEdit\Temp\JGLMPFRI.vbs(1, 16) Microsoft VBScript compilation error: Expected end of statement

***** script completed - exit code: 1 *****

I was referring to the debugger that's built into Outlook.  The code is written in VBA not VBScript.  VbsEdit, a fine tool, only works with VBScript.  Here's what I'd like you to do.

1.  Add this code to what you already have.

Sub TestAFM()
    AutoForwardMessages Application.ActiveExplorer.Selection(1)
End Sub

Select allOpen in new window

2.  Adjust the time in the code as needed.
3.  Select a message in your inbox.
4.  Switch back to the code
5.  Place the cursor inside the TestAFM subroutine
6.  Press F8.  This will start executing the code and turn the first line of code in TestAFM yellow.  Each time you press F8 Outlook will execute the highlighted line of code and move to the next line.  What I want you to do is step through the code one line at a time and see what happens.

Good morning,
I did as you suggested.

here's my finding,
on any new email, the forward code is not triggered automatically as I receive them.
However,
if I highlight any email in my inbox, and run the TestAFM Code, I do get the "Fired" message, and  I do receive the forwarded email.

thank you

Ok.  So the code works but is not firing automatically like it should.  Is there any other code in ThisOutlookSession?  Do you have any rules in place that are moving messages as they arrive?  Can you post a screenshot of the code as it appears in the VB editor in Outlook?

Hello,
please see attached screen shot.
no other codes in the ThisOutlookSession.

Please note, I xxxx the email address.

thanks .
ScreenShot1.pdf

How about rules?  Any rules that are moving messages as they arrive?  If not, then the only explanation I can think of is that Outlook is not executing the Startup procedure as it should.  To test that theory, please replace the subroutine Application_Startup with the version below.  Leave the rest of the code as is.  Once you've done that, please close and restart Outlook.  As Outlook starts it should display a pop-up saying "Application_Stratup ran".  Please let me know if that happens.  If it does, then please test by sending yourself a message.

Private Sub Application_Startup()
    MsgBox "Application_Startup ran"
    Set olkApp = Application
End Sub

Select allOpen in new window

I got the pop up message at startup.
Application_Stratup ran

Sent a test, I only received the original, not the forward.

I don't have any other rules running.

thanks,

listening ...

Look in Sent Items.  Do you see the forwarded items there?

Hello,
No, I don't see the forwarded email in the sent items.

fyi,
I found this code that seems to be working,
but with no time constraints.

 Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim varEntryID As Variant

    For Each varEntryID In Split(EntryIDCollection, ",")
        Dim objOriginalItem As mailItem
        Set objOriginalItem = Application.GetNamespace("MAPI").GetItemFromID(varEntryID)
        Dim objForwardedItem As mailItem
        Set objForwardedItem = objOriginalItem.Forward

        objForwardedItem.To = "xxxxxxx@xxxxxxxxxxx.com"
        objForwardedItem.Send
    Next
End Sub

That code is almost identical to the code I posted.  If it works, then so should the code I posted.  Can you post a screenshot of the code I posted as it appears in Outlook?

Hello,
sorry for delay,
please see attached.

thanks
ScreenShot021.pdf

thank you
thank you.
works

Thank you very much for all your time and help.

You're welcome.  Sorry it took me so long to figure out where the code was going wrong.