Monday, October 25, 2010

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.

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
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.  

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).  

@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


''' Written by Brian Kayser '''
''' Designed to be run with CSCRIPT.EXE '''


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.


' — Execute the query
Set rs = Com.Execute
' Navigate the record set
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")
  wscript.echo date &" | "& time
  zCnt = zCnt + 1 
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 = ""&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"
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"
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"
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

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
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"", """" , ""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 & """') " 
   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"
 If PurgeType="Non Archived" Then 
      SSql = SSql & " WHERE ""DAV:contentclass"" = 'urn:content-classes:message' and ""DAV:isfolder"" = false"
   If PurgeType="Spam" Then 
        SSql = SSql & " WHERE (""DAV:contentclass"" = 'urn:content-classes:PAMmessage' or ""DAV:contentclass"" = 'urn:content-classes:message') and  ""DAV:isfolder"" = false"
'' 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
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
While Not rs.EOF

   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 = ""
zFolder = zFolder & "\"
   End If
   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)

   cnt = cnt + 1
End if
wscript.echo "    Deleted " & cnt &" *"& PurgeType & "* emails from user " & zName
zTotalUserItems = zTotalUserItems + cnt

GetEmailUrlList = true
Set Rs = Nothing
Set Conn = Nothing
End Function

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

10/25/2010 | 1:26:58 AM
** John Doe -

   Processing Folder: ...\Inbox
    Deleting emails older than 12 months old:
    10/24/2009 | | Vivarium
    Deleted 1 *Inbox* emails from user John Doe

   Processing Folder: ...\Sent Items
    Deleting emails older than 12 months old:
    10/24/2009 | | Fw: Property for you
    10/24/2009 | | 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 | | Re: Hey cuz
    4/24/2010 | | Re: Hey cuz
    4/24/2010 | | Re: Hey cuz
    4/24/2010 |  | 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 | | 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


  1. Cool, this may take some time to figure out but I think it is exactly what I've been searching for. How long does it take to run?

  2. How long it takes depends (of course)! It depends on how many users and how much mail it is purging. The first time you run it, if it is purging a lot of mail, it could take a LONG time. Depending on the speed of your mail server, I would estimate that the script will delete about 5 - 10 messages every second.


Please let me know if this helped you out, or if you would like to submit other suggestions or correct something I may have mis-stated.

About Me

My photo
Science Fiction Author / Vice President of Technology for The Christman Company