Forward specific e-mails at certain times in Outlook using VBA

[luxcs]

I'm trying to use VBA to forward all certain e-mails, received from specific e-mail addresses only, when received outside of office hours.

ie. On a Saturday, Sunaday, or outside of 8am-6pm Monday to Friday, I'd like e-mails from email1@domain1 and email2@domain2 to be forwarded to an alternate e-mail address.

I've used VB and VBA before, just never with Outlook, and am looking for some assistance/guidance. I've searched the Net already, but can't get my code to work.

Also, I already have quite a lot of rules runnings to filter e-mails into specific folders. So, would this run before the rules pickup the e-mail, or can I check all folders for new mail from these addresses?


Here's what I currently have:


Public WithEvents myOlItems As Outlook.Items

Public Sub Application_Startup()
' Reference the items in the Inbox. Because myOlItems is declared
' "WithEvents" the ItemAdd event will fire below.
Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' If it's currently not between 8:00 A.M. and 6:00 P.M.
If Time() < #8:00:00 AM# Or Time() > #6:00:00 PM# Then
' Check to make sure it is an Outlook mail message, otherwise
' subsequent code will probably fail depending on what type
' of item it is.
If TypeName(Item) = "MailItem" Then
' Forward the item just received
Set myForward = Item.Forward
' Address the message
myForward.Recipients.Add "alternate@domain"
' Send it
myForward.Send
End If
End If
End Sub

Thanks for any help given

Chris

[Charlize]

I use this type of coding to perform certain actions on incoming mails. First of all you create a normal module where you put the following code.
Sub SaveAttachments(myItem As Outlook.MailItem)
'your code to check for the time'
End Sub
Now we create a rule for incoming mails by using our script 'project1.Saveattachments'. If you place this rule on top it will be performed as the first one.
Charlize

[Charlize]

This is for the times. For saturday and sunday you can specify a rule or combine it with this. There is a problem with sending (there's is a tool redemption but don't know how to use that - maybe in a week or two -).
Sub Forward_after_18() 'myItem As Outlook.MailItem
'place myItem As Outlook.MailItem between the () of Forward_after_18
'need a reference to use this as a script in the rule creation program.
'you don't actually have to use it but since we have it we shall use this object.
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
'Place a ' in front of the next line because you already defined it
'when you named your procedure
Dim myItem As Outlook.MailItem
Dim avTime() As String
Dim rTime As Date

ReDim Preserve avTime(2)

Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
'This is the default inbox folder
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
'This is the folder that's going to be processed.
'If you want inboxfolder, just put a ' in front of next line
Set myFolder = myFolder.Folders("Test")

For Each myItem In myFolder.Items
'processes all unread items in mailbox you specified
If myItem.UnRead = True Then
avTime = Split(CStr(myItem.ReceivedTime), " ")
rTime = avTime(1)
If rTime > TimeSerial(18, 0, 0) And rTime < TimeSerial(0, 0, 0) Or _
rTime > TimeSerial(0, 0, 0) And rTime < TimeSerial(8, 0, 0) Then
myItem.Forward.Recipients.Add "the addres@you.com"
myItem.Send
End If
End If
Next
End SubCharlize

[luxcs]

Charlize

Thanks for the reply. Excuse my ignorance, but how would this be put together to run automatically, on receipt of an e-mail (dependant on time and source e-mail address), but before the rules move e-mails out of the Inbox since that is the only folder being looked at.

The flow of events (in the perfect scenario) would be -:


E-mail arrives.
If time is not between 8am and 6pm Mon-Fri then
Forward e-mail to alternate address
Else

Proceed as normal
Rules would now filter e-mail to correct folder.Thanks again

[Charlize]

Put this is a normal module in outlook.Public myItem As Outlook.MailItem
Public myFolder2 As Outlook.MAPIFolder
Public Sub forward_18()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder

Dim avTime() As String
Dim rTime As Date
Dim vTime1 As Date
Dim vTime2 As Date
Dim vTime3 As Date
Dim vTime4 As Date

ReDim Preserve avTime(2)

Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
'This is the default inbox folder
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
'This is the folder that's going to be processed.
'If you want inboxfolder, just put a ' in front of next line
Set myFolder2 = myFolder.Folders("After_18")
For Each myItem In myFolder.Items
'processes all unread items in mailbox you specified
If myItem.UnRead = True Then
avTime = Split(CStr(myItem.ReceivedTime), " ")
rTime = avTime(1)
vTime1 = TimeSerial(18, 0, 0): vTime2 = TimeSerial(23, 59, 59)
vTime3 = TimeSerial(0, 0, 0): vTime4 = TimeSerial(8, 0, 0)
If rTime >= vTime1 And rTime < vTime2 Or _
rTime >= vTime3 And rTime <= vTime4 Then
myItem.Move myFolder2
'Call Mail_with_CDO
End If
End If
Next myItem
Call Mail_with_Redemption
End Sub
Sub Mail_with_Redemption()
'You must first install a dll, called redemption.dll
'You have to setup a reference to this library in outlook.
Dim Session As Object
Dim mail As Object
For Each myItem In myFolder2.Items
'processes all unread items in mailbox you specified
If myItem.UnRead = True Then
Set Session = CreateObject("Redemption.RDOSession")
Session.Logon
Set mail = Session.GetDefaultFolder(olFolderOutbox).Items.Add("IPM.Note")
mail.Subject = myItem.Subject
mail.Body = "Automatic forwarding after 18.00 - before 8.00"
mail.Recipients.Add "adress@provider"
mail.Attachments.Add myItem
myItem.UnRead = False
mail.Send
End If
Next myItem
End Sub
Add this in ThisOutlookSessionPrivate Sub Application_Startup()
'Empty to bypass the securitywarnings.
'And set the securitylevel for macros to medium
End Sub
Public Sub Forward_after_18(myItem As Outlook.MailItem) 'myItem As Outlook.MailItem
'place myItem As Outlook.MailItem between the () of Forward_after_18
'need a reference to use this as a script in the rule creation program.
'you don't actually have to use it but since we have it we shall use this object.
Call forward_18
End SubNow you make a rule for every message that you receive on your computer and choose 'perform a script' and choose Forward_after_18
Place this rule above all other rules that you have. First rule will only be run if time of message is between 18.00 - 08.00 am. For saturday and sunday you can define another rule and place this as the first one. Sat-Sun 1st rule, 2nd rule is the script and then the rest of your rules.
Charlize

[luxcs]

Thanks for that.

I've created a second script using the code as a template, which checks the day of the received mail, and if its Sat or Sun then it calls the forwarding sub.

In outlook iteself, I've created two rules....the first runs the weekend script on the e-mail if certain domains appear in the sender's address. The second runs the 18:00-08:00 script. And both these rules are at the top of the list.

In my testing, it doesn't seem to forward though. The e-mail gets moved to the correct folder, but doesn't get forwarded out.

Any ideas?

Chris

[Charlize]

Apart from not been able to see your coding for the sat-sun issue, you have to have the redemption library available (If you are going to use this for your work, they have to take a license for it. Just to make sure that you understand this.). To be able to test this : remove the checkmark from the weekend rule and the time rule you've created.

Now put a mail after 18.00 h. back in the inbox (preferable an as good as empty inbox). Go in the vba and look for the module where you've putted forward_18. Set your cursor after the sub and hit F8. With each F8 you'll see the progress of your code. When you move the mousecursor above variables, their values will be shown. Try this way to spot the problem.
Another tip : instead of calling Mail_with_Redemption with every item in your inbox you better move this line after the line with next (this should become next myitem). So first every item is moved and then the mails are going to be processed (I hope).

Charlize

ps.: adapted previous post with these remarks.