Untitled document
Public myFolder2 As Outlook.MAPIFolder
Public Sub forward_after18()
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)
myOlapp = CreateObject("Outlook.Application")
myNameSpace = myOlapp.GetNamespace("MAPI")
'This is the default inbox folder
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
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
Session = CreateObject("Redemption.RDOSession")
Session.Logon()
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