Solved

Forward all incoming emails

Posted on 2014-10-10
35
213 Views
Last Modified: 2014-10-27
Hello,
Can you please help,
I need to automatically forward all incoming emails (to a specific account (1 or more) between 7:pm to 5:00 am to (one or more) email addresses.
is there a vba that I can put in the This Outlook session , that can do this.

Thank you.
0
Comment
Question by:Wass_QA
  • 17
  • 15
  • +2
35 Comments
 
LVL 2

Expert Comment

by:Pratik Makwana
ID: 40372873
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40372955
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

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40372990
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,
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40373010
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

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40373015
it will be permanent,
I will be using the script on about 20 - 30 computers.

I appreciate your time and help,
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40373070
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                                       

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40373110
Hello,
it's not forwarding the emails.

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

thank you
0
 

Author Comment

by:Wass_QA
ID: 40373113
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 .
0
 

Author Comment

by:Wass_QA
ID: 40373287
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,
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40373846
is it between 7:00pm and 5:00am where you are?
0
 

Author Comment

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

thanks again,
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40373871
What is macro security set to?
0
 

Author Comment

by:Wass_QA
ID: 40373882
No Security check for Macros.
0
 
LVL 26

Expert Comment

by:Nick67
ID: 40373897
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374187
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                                       

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40374215
Hello,
I get 2 message boxes

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

But I only received one email.

thanks
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374272
That's fine. It proves the code is running. Are you sure you  adjusted the time correctly ?
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:Wass_QA
ID: 40374306
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374310
If you aren't getting pop-ups, then the code isn't running at all. Are you familiar with the debugger?
0
 

Author Comment

by:Wass_QA
ID: 40374331
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 *****
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374369
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

Open 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.
0
 

Author Comment

by:Wass_QA
ID: 40374655
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374770
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?
0
 

Author Comment

by:Wass_QA
ID: 40374785
Hello,
please see attached screen shot.
no other codes in the ThisOutlookSession.

Please note, I xxxx the email address.

thanks .
ScreenShot1.pdf
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40374798
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

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40374802
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,
0
 
LVL 1

Expert Comment

by:dwe0608
ID: 40389651
listening ...
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40392226
Look in Sent Items.  Do you see the forwarded items there?
0
 

Author Comment

by:Wass_QA
ID: 40396004
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40396074
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?
0
 

Author Comment

by:Wass_QA
ID: 40406854
Hello,
sorry for delay,
please see attached.

thanks
ScreenShot021.pdf
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 40407168
No worries.

I found the problem when I switched to using the time-frame you have set on your computer.  Here's what's happening.  It's 2:47PM my time and the time-frame set in the code is 1:00PM to 7:00AM.  The is the line of code that tests to see if the current time is in the desired time-frame

If (Time >= TIME_BEG) And (Time <= TIME_END) Then

Open in new window


Let's think about that in English  Is 2:47PM >= 1:00PM?  Yes it is.  Good so far.  Now, is 2:47PM <= 7:00AM?  No, it's not.  That causes the code to fall through without forwarding the message.  It's a result of the time-frame crossing days.  if the time-frame was all on the same day, then everything would work properly.

Here's a new version of the code that should fix the problem.  Please delete all the code you have now and replace it with this version.  I've included some debugging code that outputs a log file we can use in case there are still problems.  

'On the next line, please edit the path as needed.  
Const DEBUG_LOG = "c:\users\david\documents\AutoForwardMessages.log"

Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    'On the next line, edit the time forwarding is to begin
    Const TIME_BEG = #1:00:00 PM#
    'On the next line, edit the time that forwarding is to end
    Const TIME_END = #7:00:00 AM#
    'On the next line, edit the address that messages are to be forwarded to
    Const ACCT_ADDR = "someone@company.com"
    Dim arrEID As Variant, varEID As Variant, olkItm As Object
    arrEID = Split(EntryIDCollection, ",")
    For Each varEID In arrEID
        WriteToLogFile DEBUG_LOG, "--> " & varEID
        Set olkItm = Session.GetItemFromID(varEID)
        WriteToLogFile DEBUG_LOG, vbTab & "olkItm Type = " & TypeName(olkItm)
        If olkItm.Class = olMail Then
            WriteToLogFile DEBUG_LOG, vbTab & "olkItm Class = " & olkItm.Class
            If TIME_END < TIME_BEG Then
                If Time <= #11:59:59 PM# Then
                    If Time >= TIME_BEG Then
                        WriteToLogFile DEBUG_LOG, vbTab & "Forwarding the message - Cond A"
                        AutoForwardMessages olkItm, ACCT_ADDR
                    End If
                Else
                    If Time <= TIME_END Then
                        WriteToLogFile DEBUG_LOG, vbTab & "Forwarding the message - Cond B"
                        AutoForwardMessages olkItm, ACCT_ADDR
                    End If
                End If
            Else
                If (Time >= TIME_BEG) And (Time <= TIME_END) Then
                    WriteToLogFile DEBUG_LOG, vbTab & "Forwarding the message - Cond C"
                    AutoForwardMessages olkItm, ACCT_ADDR
                Else
                    WriteToLogFile DEBUG_LOG, vbTab & "Outside forwarding timeframe"
                End If
            End If
        End If
    Next
    Set olkItm = Nothing
End Sub

Sub AutoForwardMessages(Item As Outlook.MailItem, strAdr As String)
    Dim olkFwd As Outlook.MailItem
    Set olkFwd = Item.Forward
    olkFwd.To = strAdr
    olkFwd.Send
    Set olkFwd = Nothing
End Sub
                                          
Sub WriteToLogFile(strLog, strMsg)
    Const ForAppending = 8
    Dim objFSO, objFil
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFil = objFSO.OpenTextFile(strLog, ForAppending, True)
    objFil.WriteLine Now & vbTab & strMsg
    objFil.Close
    Set objFil = Nothing
    Set objFSO = Nothing
End Sub

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 40407181
thank you
thank you.
works
0
 

Author Closing Comment

by:Wass_QA
ID: 40407184
Thank you very much for all your time and help.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40407449
You're welcome.  Sorry it took me so long to figure out where the code was going wrong.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …

760 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

Need Help in Real-Time?

Connect with top rated Experts

24 Experts available now in Live!

Get 1:1 Help Now