Purge email script for Exchange

Please note, I talk a lot about Sunbelt's Exchange Archiver below but this purge script could be used with other archive solutions or even without one, just as a purge.  Obviously you will want to take care that you don't purge valuable data.  The Exchange server I'm running this on is Exchange 2003.

PROBLEM
Implemented Sunbelt Exchange Archiver (SEA) but wanted more control over how emails were purged from the actual Exchange server.  I wanted specific policies for my user's Inbox, Sent Items, Deleted Items, and our Spam folder.  SEA removes emails from Exchange and leaves short-cuts or "stubs" which allows you to still open the emails, they just get retrieved from the archive server instead of Exchange.  I have SEA setup to remove the emails after 3 months leaving stubs, SEA has a global setting as to how long to keep these stubs in Exchange / Outlook.  I have SEA setup to keep these for 4 years but I really didn't want them hanging around for that long in certain folders.  I figure if the user takes the time to file the message in a folder, they can keep the stub for 4 years, otherwise if it is left in the Inbox or Deleted folder it shouldn't hang around as long.  Even though the stub isn't taking up that much space in Exchange, it can make Outlook run slow.  For example, say a user never files anything and keeps all emails in their inbox.  Their inbox may have say 30,000 items in it.  Okay, maybe the Exchange server is only holding the full emails for the last 3 months (in my case) it still has all these stubs to deal with and index.  When the user switches sort orders, Outlook has to work with all 30,000 items to rearrange the sort, making it very slow.  My thinking is that if it is over 1 year old and still in the Inbox they probably don't care about it any longer.  If they do need to find it, they can search for it in the Archive as it will still be there.

Here are my policies that I wanted to implement:

• All emails (unless specified) get copied to archive server after 7 days if not sent to deleted folder
• SEA removes email from Exchange after 3 months, leaving stub / shortcut
• InBox - remove email stubs after 12 months (don't remove anything that isn't archived)
• Deleted Items - Don't archive at all, delete anything in there after 6 months
• Sent Items - remove email stubs after 12 months 
• Spam Folder - Don't archive at all, delete anything in there after 3 months

SOLUTION

There are ways to purge emails directly within Exchange but it did not give me the granularity I wanted so I wrote a VBscript to do the job.  The script reads the users from Active Directory and only runs in on users with a special flag set.  On each user's property page, there is a value for "Web Page" that we never use.  I have the script setup to read that value and if it is set to "PurgeEmail=Yes" then the script will run for them.  I also picked the "Web Page" property because it is available to modify when selecting multiple users at one time so it is easy to add to a big group of users.  

The script then whips through each user, one at a time, and cleans up their email.  This has reduced a huge amount storage needs on our Exchange server that would have taken SEA over a year to accomplish alone.  I'm not going to go into the script line by line, just be careful.  

***THE SCRIPT***

Batch File

Here is a batch file that is launched via a scheduled task.  The script produces output so this does a simple pipe to log files (I'm maintaining 7 days of log files).  

EMAIL-CLEANUP.BAT

@Set Weekday=%Date:~0,3%

Echo Start -> %date%  %Time% > email-cleanup-%Weekday%.log

cscript email-cleanup.vbs //nologo >> email-cleanup-%Weekday%.log

Echo Finished -> %date%  %Time% >> email-cleanup-%Weekday%.log

VBScript   
EMAIL-CLEANUP.VBS

''' Written by Brian Kayser '''

''' Designed to be run with CSCRIPT.EXE '''

ON ERROR RESUME NEXT

Dim zTotalUserItems

Dim zTotalCnt(3)

Dim cnt

Dim zFlags

Set WshShell = CreateObject("WScript.Shell")

zCat = "user"

zDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")

'Create connection and command object

Set con = CreateObject("ADODB.Connection")

Set com = CreateObject("ADODB.Command")

' — Opening the connection

con.Provider = "ADsDSOObject"  'this is the ADSI-OLEDB provider name

con.Open "Active Directory Provider"

' Create a command object for this connection

Set Com.ActiveConnection = con

'============================================================================================='

'Compose a search string

Com.CommandText = "select Name,mail, wwwHomePage from 'LDAP://"&zDomain&"' WHERE Objectcategory='" & zCat & "' AND wwwHomePage = 'purgeemail=Yes*' order by name"

'wscript.echo Com.CommandText   'uncomment this line for debugging purposes.

wscript.echo 

' — Execute the query

Set rs = Com.Execute

'--------------------------------------

' Navigate the record set

'--------------------------------------

zCnt=0

wscript.echo "Running mailbox cleanup"

wscript.echo date &" | "& time

While Not rs.EOF

  zName = rs.Fields("Name")

  wscript.echo "** " & zName &" - "& rs.Fields("mail")

  zFlags = rs.Fields("wwwHomePage")

  email_cleanup(rs.Fields("mail"))

  wscript.echo date &" | "& time

  rs.MoveNext

  zCnt = zCnt + 1 

Wend

WScript.StdOut.Write vbCrLf

WScript.StdOut.Write vbCrLf

wscript.echo "Deleted " &zTotalCnt(0)& " total items from *Inbox* folders"

wscript.echo "Deleted " &zTotalCnt(1)& " total items from *Sent Items* folders"

wscript.echo "Deleted " &zTotalCnt(2)& " total items from *Deleted Items* folders"

wscript.echo "Deleted " &zTotalCnt(3)& " total items from *Spam* folders"

zGrandTotal = zTotalCnt(0) + zTotalCnt(1) + zTotalCnt(2) + zTotalCnt(3)

wscript.echo "---------------------------------------------------------"

wscript.echo "Deleted " &zGrandTotal& " total items"

WScript.StdOut.Write vbCrLf

wscript.echo zCnt & " Users processed"

'=================Email Clean-up Script=============================

Function email_cleanup(zMailbox)

Dim ExchangeFolderUrl

zTotalUserItems = 0

ExchangeFolderUrl = "http://email.XYZCompany.com/exchange/"&zMailbox

'Inbox and Sent Items processing will only delete messages that have been archived and have a SEA shortcut

'Spam processing will delete Archived and Non Archived emails

'Deleted Items processing will delete all items (mail, calender, etc) even if not archived.

Dim FoldersToCheck(3)

Dim MessageTypesToPurge(3)

Dim AgedMonths(3)

FoldersToCheck(0) = "Inbox"

MessageTypesToPurge(0)="Inbox"

AgedMonths(0) = 12

FoldersToCheck(1) = "Sent Items"

MessageTypesToPurge(1)="Sent Items"

AgedMonths(1) = 12

FoldersToCheck(2) = "Deleted Items"

MessageTypesToPurge(2)="Deleted Items"

AgedMonths(2) = 6

FoldersToCheck(3) = "Spam\Spam - Quarantine"

MessageTypesToPurge(3)="Spam"

AgedMonths(3) = 3

Dim Fcnt

Fcnt = UBound(FoldersToCheck)

For x = 0 to Fcnt

   Dim UrlToProcess

   UrlToProcess = ExchangeFolderUrl + "/" + FoldersToCheck(x)

   Dim Emails

   Emails = Array()

   WScript.StdOut.Write vbCrLf

   WScript.StdOut.Write "   Processing Folder: ...\" + right(FoldersToCheck(x) + vbCrLf,66)

   If lcase(zFlags) = "purgeemail=yes-nodeletedfolder" and FoldersToCheck(x) = "Deleted Items" Then 

WSCript.Echo "   Skipping *Deleted Items* Folder for this user"

   Else

If Not GetEmailUrlList(UrlToProcess, Emails, AgedMonths(x),MessageTypesToPurge(x)) Then

wscript.Echo("Failed to get email list for: " + UrlToProcess)

End If

zTotalCnt(x) = zTotalCnt(x) + cnt

   End If

Next

wscript.echo "Deleted " &zTotalUserItems& " total items from " & zName & "'s mailbox"

WScript.StdOut.Write vbCrLf

WScript.StdOut.Write vbCrLf

End Function

''' GetEmailUrlList  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'

' Retrieves a list of permanent URLs that can be used to access the list of emails in a 

' folder

' folderUrl - the url of the email folder to enumerate

' arr - an empty dynamic array that this function will redim and fill

' return value - false on error, true other wise

Function GetEmailUrlList(folderUrl, ByRef arr, AgedMonths,PurgeType)

GetEmailUrlList = False

Dim filterDate

filterDate = DateAdd("m", -AgedMonths, Date())

m = CStr(Month(filterDate))

if len(m) = 1 Then

    m = "0" + m

  End If

  

  d = Cstr(Day(filterDate))

  if len(d) = 1 Then

    d = "0" + d

  End If

  

Dim DateStr

DateStr = CStr(Year(filterDate)) + "-" + m + "-" + d + "T00:00:00Z"

  

' open a connection

Dim Conn

Set Conn = CreateObject("ADODB.Connection")

Conn.Provider = "ExOLEDB.DataSource"

Conn.Open folderUrl

If Conn.Errors.Count > 0 OR Conn.State <> 1 Then

Conn.Close

Set Conn = Nothing

Exit Function

End if

' create a recordset

Dim Rs

Set Rs = CreateObject("ADODB.Recordset")

' The SQL command

Dim SSql

SSql = "Select ""DAV:href"",""DAV:parentname"", ""http://schemas.microsoft.com/exchange/permanenturl"" , ""urn:schemas:mailheader:subject"" ,""urn:schemas:httpmail:datereceived"" , ""urn:schemas:httpmail:fromemail"" "

If PurgeType="Deleted Items" Then 

   SSql = SSql & " FROM scope('Deep traversal of """ & folderUrl & """') " 

Else

   SSql = SSql & " FROM scope('shallow traversal of """ & folderUrl & """') " 

End If

If PurgeType="Inbox" or PurgeType = "Sent Items" Then

   SSql = SSql & " WHERE ""DAV:contentclass"" = 'urn:content-classes:PAMmessage' and ""DAV:isfolder"" = false"

Else

 If PurgeType="Non Archived" Then 

      SSql = SSql & " WHERE ""DAV:contentclass"" = 'urn:content-classes:message' and ""DAV:isfolder"" = false"

 Else

   If PurgeType="Spam" Then 

        SSql = SSql & " WHERE (""DAV:contentclass"" = 'urn:content-classes:PAMmessage' or ""DAV:contentclass"" = 'urn:content-classes:message') and  ""DAV:isfolder"" = false"

   Else

'' Deleted items - everything / every type

        SSql = SSql & " WHERE ""DAV:isfolder"" = false"

   End If

 End If

End If

SSql = SSql & " AND ""urn:schemas:httpmail:datereceived"" < CAST(""" & DateStr & """ As 'dateTime')"

  

' Open the recordset

Rs.CursorLocation = 2 'adUseServer = 2, adUseClient = 3

Rs.CursorType = 0

Rs.Open SSql, Conn, 3

If Conn.Errors.Count > 0 OR Rs.State <> 1 Then

Rs.Close

Conn.Close

Set Rs = Nothing

Set Conn = Nothing

Exit Function

End If

wscript.echo "    Deleting emails older than " &AgedMonths& " months old:" 

cnt = 0

If Rs.Recordcount > 0 Then

cnt = 0

rs.MoveFirst

While Not rs.EOF

   zDate=split(rs.fields("urn:schemas:httpmail:datereceived"))

   zFromEmail=rs.fields("urn:schemas:httpmail:fromemail")

   zSubject=rs.fields("urn:schemas:mailheader:subject")

   If PurgeType="Deleted Items" Then

   zParent = Replace(rs.fields("Dav:parentname"),"%20"," ")

   zLen = Len(zParent)

   zPos = InStrRev(zParent,"/")

   zFolder = Right(zParent,zLen-zPos)

   If zFolder = "Deleted Items" then 

zFolder = ""

   Else

zFolder = zFolder & "\"

   End If

   Else

   zFolder = ""

   End If

   zPart1= left(zDate(0) &" | "& zFromEmail,34)

   zPart2= " | "& zFolder & zSubject

   zLine = left(zPart1 & zPart2,100)

'    zLine = zPart1 & zPart2

   Wscript.echo "    "& zLine

''''''''''' comment out this next line for testing (read-only)

   rs.Delete

   rs.MoveNext

   cnt = cnt + 1

Wend

End if

wscript.echo "    Deleted " & cnt &" *"& PurgeType & "* emails from user " & zName

zTotalUserItems = zTotalUserItems + cnt

GetEmailUrlList = true

Rs.Close

Conn.Close

Set Rs = Nothing

Set Conn = Nothing

End Function

***OUTPUT***

As written, the script does produce output, here is a sample:

10/25/2010 | 1:26:58 AM

** John Doe - john.doe@XYZCompany.com

   Processing Folder: ...\Inbox

    Deleting emails older than 12 months old:

    10/24/2009 | Jill@XYZarchitect.co | Vivarium

    Deleted 1 *Inbox* emails from user John Doe

   Processing Folder: ...\Sent Items

    Deleting emails older than 12 months old:

    10/24/2009 | john.doe@XYZCompany.com | Fw: Property for you

    10/24/2009 | john.doe@XYZCompany.com | Fw: Property for you

    Deleted 2 *Sent Items* emails from user John Doe

   Processing Folder: ...\Deleted Items

    Deleting emails older than 6 months old:

    4/24/2010 | Adededdcellee@aol.com | Re: Hey cuz

    4/24/2010 | Adededdcellee@aol.com | Re: Hey cuz

    4/24/2010 | Adededdcellee@aol.com | Re: Hey cuz

    4/24/2010 | Jill@XYZarchitect.co  | Re: Did you see that

    Deleted 4 *Deleted Items* emails from user John Doe

   Processing Folder: ...\Spam\Spam - Quarantine

    Deleting emails older than 3 months old:

    7/24/2010 | mailing@dayspring.com | Overcoming Fear & Worry

    7/24/2010 | WhiteFlowerFarm@whitef | Add Perfume to Your Garden 

    Deleted 2 *Spam* emails from user John Doe

Deleted 10 total items from  John Doe's mailbox