Solved

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

Posted on 2007-11-30
18
738 Views
Last Modified: 2010-04-21
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
0
Comment
Question by:bhendrick
  • 9
  • 9
18 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 20384283
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.
0
 

Author Comment

by:bhendrick
ID: 20385442
I would like to have it run from machine "Booking02" or user "tracy.steel" at say a 15 minute interval.
0
 
LVL 76

Expert Comment

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

0
 

Author Comment

by:bhendrick
ID: 20401826
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.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20407425
Brian,

Change this line

    Function OpenOutlookFolder(strFolderPath As String)

to

    Function OpenOutlookFolder(strFolderPath)
0
 

Author Comment

by:bhendrick
ID: 20409853
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
0
 

Author Comment

by:bhendrick
ID: 20410274
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

0
 
LVL 76

Expert Comment

by:David Lee
ID: 20416200
Line 40 needs to read

    Function OpenOutlookFolder(strFolderPath)

Take off the

    As String)

at the end.
0
 

Author Comment

by:bhendrick
ID: 20418103
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.
0
Too many email signature changes to deal with?

Are you constantly being asked to update your organization's email signatures? Do they take up too much of your time? Wouldn't you love to be able to manage all signatures from one central location, easily design them and deploy them quickly to users. Well, you can!

 
LVL 76

Expert Comment

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

0
 

Author Comment

by:bhendrick
ID: 20571530
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.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20571763
Happy New Year, Brian.

It shouldn't be necessary, but try changing GetObject to WScript.GetObject.
0
 

Author Comment

by:bhendrick
ID: 20571786
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20571820
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")



0
 

Author Comment

by:bhendrick
ID: 20571844
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
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 20571870
Ok, add this line of code immediately after line #1

    On Error Resume Next
0
 

Author Closing Comment

by:bhendrick
ID: 31411896
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20572204
Thanks, Brian.  I'm glad I was able to help out.  
0

Featured Post

Highfive Gives IT Their Time Back

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

Suggested Solutions

Title # Comments Views Activity
outlook, calendar, exchange 10 27
Older clients and Exchange 2016 5 39
cached or not 5 41
Is it safe to Allow Malformed MIME? 5 21
Marketers need statistics and metrics like everybody else needs oxygen. In this article we explain how to enable marketing campaign statistics for Microsoft Exchange mail.
This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
In this video we show how to create an email address policy in Exchange 2013. We show this process by using the Exchange Admin Center. Log into Exchange Admin Center.:  First we need to log into the Exchange Admin Center. Navigate to the Mail Flow…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

757 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

21 Experts available now in Live!

Get 1:1 Help Now