Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 269
  • Last Modified:

Forward all incoming emails

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
W.E.B
Asked:
W.E.B
  • 17
  • 15
  • +2
1 Solution
 
Pratik MakwanaData AnalystCommented:
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
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
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
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
David LeeCommented:
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
 
W.E.BAuthor Commented:
it will be permanent,
I will be using the script on about 20 - 30 computers.

I appreciate your time and help,
0
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
Hello,
it's not forwarding the emails.

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

thank you
0
 
W.E.BAuthor Commented:
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
 
W.E.BAuthor Commented:
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
 
David LeeCommented:
is it between 7:00pm and 5:00am where you are?
0
 
W.E.BAuthor Commented:
I changed the time (for my testing)
    Const TIME_BEG = #2:00:00 PM#
    Const TIME_END = #3:59:59 PM#

thanks again,
0
 
David LeeCommented:
What is macro security set to?
0
 
W.E.BAuthor Commented:
No Security check for Macros.
0
 
Nick67Commented:
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
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
Hello,
I get 2 message boxes

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

But I only received one email.

thanks
0
 
David LeeCommented:
That's fine. It proves the code is running. Are you sure you  adjusted the time correctly ?
0
 
W.E.BAuthor Commented:
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
 
David LeeCommented:
If you aren't getting pop-ups, then the code isn't running at all. Are you familiar with the debugger?
0
 
W.E.BAuthor Commented:
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
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
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
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
Hello,
please see attached screen shot.
no other codes in the ThisOutlookSession.

Please note, I xxxx the email address.

thanks .
ScreenShot1.pdf
0
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
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
 
dwe0608Commented:
listening ...
0
 
David LeeCommented:
Look in Sent Items.  Do you see the forwarded items there?
0
 
W.E.BAuthor Commented:
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
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
Hello,
sorry for delay,
please see attached.

thanks
ScreenShot021.pdf
0
 
David LeeCommented:
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
 
W.E.BAuthor Commented:
thank you
thank you.
works
0
 
W.E.BAuthor Commented:
Thank you very much for all your time and help.
0
 
David LeeCommented:
You're welcome.  Sorry it took me so long to figure out where the code was going wrong.
0

Featured Post

Granular recovery for Microsoft Exchange

With Veeam Explorer for Microsoft Exchange you can choose the Exchange Servers and restore points you’re interested in, and Veeam Explorer will present the contents of those mailbox stores for browsing, searching and exporting.

  • 17
  • 15
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now