Calendar Archive Script Using WebDAV

UPDATE: December 12, 2008: Chris graciously updated the script and a copy is here.

One of our favorite calendar-oriented developers (Christopher Quinn from Milwaukee, Wisconsin) produced this script to archive an entire year’s worth of calendar data to an Archive folder in Outlook (as opposed to a separate PST file). The advantages of this are that moving old calendar items to an archive folder speeds Outlook calendar functions and still leaves the data readily accessible to users.

This script also has the advantage of allowing an administrator to auto-archive without user intervention.

'webmailserver = Host Server for mailbox
'ArchiveYear = Year to archive before
'mailbox = mailbox
Dim itemsArchived, TotalArchivedItems

webmailserver = "9to5server"
ArchiveYear = "2006"
mailbox = jane.doe@yourcompany.com

qdatesed = ArchiveYear & "-12-31T00:00:00Z"
boURL = "http://" & webmailserver & "/exchange/"
CalendarURL = boURL & mailbox & "/calendar/"
ArchiveURL = boURL & mailbox & "/inbox/"& ArchiveYear & " Archive Calendar"

Call elog("Begin mailbox " & mailbox)

Call CreateFolder(ArchiveURL)

Set Rec = CreateObject("ADODB.Record")
Set Rs = CreateObject("ADODB.Recordset")
Set Conn = CreateObject("ADODB.Connection")
Conn.Provider = "ExOLEDB.DataSource"
Rec.Open CalendarURL, ,3

Do
Call archive()
TotalArchivedItems = TotalArchivedItems + itemsArchived
Loop While itemsArchived > 0

Call elog("Archived " & TotalArchivedItems & " items for " & Mailbox)

Sub archive()
itemsArchived = 0
Ssql = "SELECT ""DAV:href"", " & _
" ""urn:schemas:httpmail:subject"", " & _
" ""urn:schemas:calendar:dtstart"", " & _
" ""urn:schemas:calendar:dtend"", " & _
" ""urn:schemas:calendar:rrule"", " & _
" ""http://schemas.microsoft.com/mapi/proptag/x81960040"", " & _
" ""DAV:contentclass"" " & _
"FROM scope('shallow traversal of """ & CalendarURL & """') " & _
"WHERE (""urn:schemas:calendar:dtend"" <>
" AND ""DAV:contentclass"" = 'urn:content-classes:appointment'" '& _

Rs.CursorLocation = 2 'adUseServer = 2, adUseClient = 3
Rs.open SSql, rec.ActiveConnection, 3

while not rs.eof
STRsubject = rs.Fields("urn:schemas:httpmail:subject").Value
STRstart = rs.Fields("urn:schemas:calendar:dtstart").Value
STRend = rs.Fields("urn:schemas:calendar:dtend").Value
RecEndDate = rs.Fields("http://schemas.microsoft.com/mapi/proptag/x81960040").Value

recurring = rs.Fields("urn:schemas:calendar:rrule")

If IsArray(recurring) Then

If isodateit(RecEndDate) <>
Call movemessage(rs.Fields("DAV:href").Value,"/calendar/","/inbox/"& ArchiveYear & " Archive Calendar/", boURL & mailbox)
Call elog ("Archiving," & "," & STRsubject & "," & STRstart & "," & STRend & "," & RecEndDate)
itemsArchived = itemsArchived + 1 Else
Call elog ("SKIPPING--------->," & "," & STRsubject & "," & STRstart & "," & STRend & "," & RecEndDate)
End If

Else
Call movemessage(rs.Fields("DAV:href").Value,"/calendar/","/inbox/"& ArchiveYear & " Archive Calendar/", boURL & mailbox)
Call elog ("Archiving," & "," & STRsubject & "," & STRstart & "," & STRend & "," & RecEndDate)
itemsArchived = itemsArchived + 1
End If

rs.movenext
Wend

rs.Close
End Sub

'Convert Date String to ISO format
function isodateit(datetocon)
strDateTime = year(datetocon) & "-"
if (Month(datetocon) < strdatetime =" strDateTime">
strDateTime = strDateTime & Month(datetocon) & "-"
if (Day(datetocon) < strdatetime =" strDateTime">
strDateTime = strDateTime & Day(datetocon) & "T" & formatdatetime(datetocon,4) & ":00Z"
isodateit = strDateTime
end function

'Move the Item to the Archive folder
Sub movemessage(mSource,mSourceFolder,mDestFolder,mBoxURL)
On Error Resume Next
mDest = Replace(lcase(mSource),mSourceFolder,mDestFolder)
Set mRec = CreateObject("ADODB.Record")
mRec.Open mBoxURL, ,3
If Err.Number <> 0 Then
Call elog(Err.Number & vbTab & Err.Description)
Err.Clear
End If
mRec.MoveRecord mSource, mDest
If Err.Number <> 0 Then
Call elog(Err.Number & vbTab & Err.Description)
Err.Clear
End If
mRec.Close
End Sub

'Create Folder if it doesn't already exists
Sub CreateFolder(strFolderUrl)
On Error Resume Next
set nfRec = CreateObject("ADODB.Record")
nfRec.Open strFolderUrl, , 3, 8912
nfRec.Fields("DAV:contentclass") = "urn:content-classes:folder"
nfRec.Fields("http://schemas.microsoft.com/exchange/outlookfolderclass") = "IPF.Appointment"
nfRec.Fields.Update
nfRec.Close
Set nfRec = Nothing
End Sub

Sub elog(logstring)
WScript.Echo logstring
End Sub