Link to home
Start Free TrialLog in
Avatar of bhendrick
bhendrickFlag for United Kingdom of Great Britain and Northern Ireland

asked on

Monitor a public folder & move "READ Messages" to another folder at an interval

Hi All,
We are using SBS 2003 exchange. I have a pulic folder called INPUT, I am Using Sperry Softwares AutoPrint Oultook addin to monitor this folder, And print all emails & attachments in the folder & mark each email as read once printed.

To complete a required set process I now need to set something up to scan this folder at intervals to move the "Read" messages to a subfolder called "Processed". In addition I would like to check & delete all emails from the "Processed" subfolder that are older than 60 days.

Does anyone know of an addin or macro that can do this as message rules are not able to only move Read items.
Cheerz

Bri
Avatar of David Lee
David Lee
Flag of United States of America image

Hi, bhendrick.

Yes, this is possible with a fairly simple bit of scripting.  How often does the process need to run and where do you see it running from (i.e. who's computer)?  That user will have to have Outlook up and running for the script to run.
Avatar of bhendrick

ASKER

I would like to have it run from machine "Booking02" or user "tracy.steel" at say a 15 minute interval.
The best solution is an external script set to run via Windows Scheduled Tasks.  Follow these instructions to use this.

1.  Copy the script below and paste it into Notepad.  
2.  Save the file with a .vbs extension.  
3.  Using Windows Scheduled Tasks create a task that runs at 15 minute intervals.  Set the task to run this script.

I have not tested this script.  Use it cautiously until you have tested it.  Let me know if you run into problems and I'll correct them as quick as I can.
Dim olkApp, olkFolderInput, olkFolderProcessed, olkItems, olkItem, olkSession, intIndex
'Get the open itteration of Outlook
Set olkApp = GetObject(, "Outlook.Application")
'If Outlook was open
If TypeName(olkApp) <> "Nothing" Then
    Set olkSession = olkApp.Session
    'Get the Input folder
    'Change the folder path on the following line as needed
    Set olkFolderInput = OpenOutlookFolder("Public Folders\All Public Folders\Input")
    'Get the Processed folder
    'Change the folder path on the following line as needed
    Set olkFolderProcessed = OpenOutlookFolder("Public Folders\All Public Folders\Input\Processed")
    'Get all the read items
    Set olkItems = olkFolderInput.Items.Restrict("[Unread] = False")
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Move the read item to the Processed folder
        olkItem.Move olkFolderProcessed
    Next
    
    'Get all the items in the Processed folder
    Set olkItems = olkFolderProcessed.Items
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Was the item more than 60 days old?
        If DateDiff("d", olkItem.ReceivedTime, Date) > 60 Then
            'Delete it
            olkItem.Delete
        End If
    Next
End If
Set olkItem = Nothing
Set olkItems = Nothing
Set olkFolderInput = Nothing
Set olkFolderProcessed = Nothing
Set olkSession = Nothing
Set olkApp = Nothing
WScript.Quit
 
Function OpenOutlookFolder(strFolderPath As String)
    Dim arrFolders, varFolder, olkFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = olkSession.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

Thank you BlueDevilFan:

I have just tested the script as you suggested and get the following error when its is run.

Windows Script Host

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 40
Char: 42
Error: Expected ')'
Code: 800A03EE
Source: Microsoft VBScript compilation error.

Thanks
Brian.
Brian,

Change this line

    Function OpenOutlookFolder(strFolderPath As String)

to

    Function OpenOutlookFolder(strFolderPath)
BlueDevilFan,
 Done as stated, Now errors on next char.

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 40
Char: 43
Error: Expected Statement
Code: 800A0400
Source: Microsoft VBScript compilation error.

Regards
Bri
Just to confirm, I have uploaded the code as ammended.
Dim olkApp, olkFolderInput, olkFolderProcessed, olkItems, olkItem, olkSession, intIndex
'Get the open itteration of Outlook
Set olkApp = GetObject(, "Outlook.Application")
'If Outlook was open
If TypeName(olkApp) <> "Nothing" Then
    Set olkSession = olkApp.Session
    'Get the Input folder
    'Change the folder path on the following line as needed
    Set olkFolderInput = OpenOutlookFolder("Public Folders\All Public Folders\Input")
    'Get the Processed folder
    'Change the folder path on the following line as needed
    Set olkFolderProcessed = OpenOutlookFolder("Public Folders\All Public Folders\Input\Processed")
    'Get all the read items
    Set olkItems = olkFolderInput.Items.Restrict("[Unread] = False")
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Move the read item to the Processed folder
        olkItem.Move olkFolderProcessed
    Next
    
    'Get all the items in the Processed folder
    Set olkItems = olkFolderProcessed.Items
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Was the item more than 60 days old?
        If DateDiff("d", olkItem.ReceivedTime, Date) > 60 Then
            'Delete it
            olkItem.Delete
        End If
    Next
End If
Set olkItem = Nothing
Set olkItems = Nothing
Set olkFolderInput = Nothing
Set olkFolderProcessed = Nothing
Set olkSession = Nothing
Set olkApp = Nothing
WScript.Quit
 
Function OpenOutlookFolder(strFolderPath) As String)
    Dim arrFolders, varFolder, olkFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = olkSession.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

Line 40 needs to read

    Function OpenOutlookFolder(strFolderPath)

Take off the

    As String)

at the end.
BlueDevilFan

Sorry m8, Done as you asked, Now error on the following.

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 42
Char: 19
Error: Syntax error
Code: 800A03EA
Source: Microsoft VBScript compilation error.

Thanks.
Try this version.
Dim olkApp, olkFolderInput, olkFolderProcessed, olkItems, olkItem, olkSession, intIndex
'Get the open itteration of Outlook
Set olkApp = GetObject(, "Outlook.Application")
'If Outlook was open
If TypeName(olkApp) <> "Nothing" Then
    Set olkSession = olkApp.Session
    'Get the Input folder
    'Change the folder path on the following line as needed
    Set olkFolderInput = OpenOutlookFolder("Public Folders\All Public Folders\Input")
    'Get the Processed folder
    'Change the folder path on the following line as needed
    Set olkFolderProcessed = OpenOutlookFolder("Public Folders\All Public Folders\Input\Processed")
    'Get all the read items
    Set olkItems = olkFolderInput.Items.Restrict("[Unread] = False")
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Move the read item to the Processed folder
        olkItem.Move olkFolderProcessed
    Next
    
    'Get all the items in the Processed folder
    Set olkItems = olkFolderProcessed.Items
    For intIndex = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intIndex)
        'Was the item more than 60 days old?
        If DateDiff("d", olkItem.ReceivedTime, Date) > 60 Then
            'Delete it
            olkItem.Delete
        End If
    Next
End If
Set olkItem = Nothing
Set olkItems = Nothing
Set olkFolderInput = Nothing
Set olkFolderProcessed = Nothing
Set olkSession = Nothing
Set olkApp = Nothing
WScript.Quit
 
Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, olkFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = olkSession.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
End Function
 
Function IsNothing(obj)
  Dim varTypeName
  varTypeName = TypeName(obj)
  Select Case varTypeName
  	Case "Nothing","Empty"
  		IsNothing = True
  	Case Else
  		IsNothing = False
  End Select
End Function

Open in new window

Hi,
         I finaly got round to looking at the new version of the script, It now errors on the following.

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 3
Char: 1
Error: ActiveX component can`t create object: 'GetObject'
Code: 800A01AD
Source: Microsoft VBScript runtime error.

Wishing you all a very Happy & Prosperous New Year
& Thanks for the help so far.

Brian.
Happy New Year, Brian.

It shouldn't be necessary, but try changing GetObject to WScript.GetObject.
Hi BlueDevilFan
Just tried as you asked, Result as follows

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 3
Char: 1
Error: Argument not optional: 'WScript.GetObject'
Code: 800A01C1
Source: Microsoft VBScript runtime error.

Thanks
Bri
Oops, sorry, was getting CreateObject and GetObject confused.  Change back to just GetObject.  Try taking the space out so that line three reads

Set olkApp = GetObject(,"Outlook.Application")



Hi BlueDevilFan
Ok thanks, Done that, Result same as earlier.

Script: C:\Scripts\Clear_Read_Emails.vbs
Line: 3
Char: 1
Error: ActiveX component can`t create object: 'GetObject'
Code: 800A01AD
Source: Microsoft VBScript runtime error.

Thanks
Bri
ASKER CERTIFIED SOLUTION
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Hi BlueDevilFan
 Thanks for all the help.

Works like a charm, Just tested it by dumping 25 emails older than 60 days into the processed subfolder, manually ran the script and its gone through and removed them correctly, I will test it a few more times then set it up as a scheduled task.

Once again Many thanks for this. You are a star.
Regards
Brian
Thanks, Brian.  I'm glad I was able to help out.