'archive the items for a mailbox
Option Explicit
Dim webmailserver, smtpMailBox, ArchiveYear, archiveFolder, savepath
Dim qdatesed,boURL,CalendarURL,ArchiveURL,Calendar_Folder_Name,Inbox_Folder_Name
Dim Rec,Rs,Conn,Ssql,recurring,RecEndDate,bcontinue
bcontinue = True

webmailserver = wscript.Arguments(0)
smtpMailBox = WScript.Arguments(1)
ArchiveYear = WScript.Arguments(2)
ArchiveURL = WScript.Arguments(3)
savepath = WScript.Arguments(4) & "\"

qdatesed = ArchiveYear & "-12-31T23:59:59Z"
boURL = "http://" & webmailserver & "/exchange/"
CalendarURL = getDefaultFolder(boURL & smtpMailBox & "/","urn:schemas:httpmail:calendar")

Calendar_Folder_Name = FindLastWord(CalendarURL,"/")
Inbox_Folder_Name = FindLastWord(getDefaultFolder(boURL & smtpMailBox & "/","urn:schemas:httpmail:inbox"),"/")
archiveFolder = Inbox_Folder_Name & "/" & FindLastWord(ArchiveURL,"/")
Call CreateFolder(ArchiveURL)
e "cscript.exe removefolder.vbs " & Chr(34) & ArchiveURL & Chr(34),"batchremovefolders.bat"

Set Rec = CreateObject("ADODB.Record")
set Rs = CreateObject("ADODB.Recordset")
Set Conn = CreateObject("ADODB.Connection")
Conn.Provider = "ExOLEDB.DataSource"
Rec.Open CalendarURL, ,3
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"", " & _
	   " ""http://schemas.microsoft.com/mapi/proptag/x81980040"", " & _
	   " ""DAV:contentclass"" " & _
       "FROM scope('shallow traversal of """ & ArchiveURL & """') " & _
       "WHERE (""http://schemas.microsoft.com/mapi/proptag/x81960040"" > CAST(""" & qdatesed & """ as 'dateTime')" & _
       " OR ""http://schemas.microsoft.com/mapi/proptag/x81980040"" > CAST(""" & qdatesed & """ as 'dateTime'))" & _
       " AND ""urn:schemas:calendar:instancetype"" = 1" & _
	   " AND ""DAV:contentclass"" = 'urn:content-classes:appointment'" 
Rs.CursorLocation = 2 
rs.open SSql, rec.ActiveConnection, 3
while not rs.eof

On Error Resume Next
recurring = rs.Fields("urn:schemas:calendar:rrule")
If Err.Number <> 0 Then
	bcontinue = False
End If
On Error Goto 0

If bcontinue Then
	If IsArray(recurring) Then
		e smtpMailBox & vbTab & rs.Fields("urn:schemas:httpmail:subject").Value,""
		on error resume Next
		RecEndDate = isodateit(rs.Fields("http://schemas.microsoft.com/mapi/proptag/x81960040").Value)
		if err.number <> 0 Then
			Err.Clear
			RecEndDate = isodateit(rs.Fields("http://schemas.microsoft.com/mapi/proptag/x81980040").Value)
			if err.number <> 0 Then

				e smtpMailBox & vbTab & rs.Fields("urn:schemas:httpmail:subject").Value & vbTab & rs.Fields("DAV:href").Value & vbtab & "Error Reading Recurring End Date","Error.log"
				err.clear
				recEndDate = "12/31/" & ArchiveYear
			End If
		end if
		on error goto 0
		If RecEndDate < isodateit("1/1/" & (ArchiveYear + 1)) Then
			Call movemessage(rs.Fields("DAV:href").Value,"/" & archiveFolder & "/", boURL & smtpMailBox,Calendar_Folder_Name)
		End If
	Else
		e "skipping non recurring Item " & rs.Fields("DAV:href").Value,""
	End If
Else 
	e smtpMailBox & vbTab & rs.Fields("DAV:href").Value,"Error.log"
End If
rs.movenext
wend
rs.close

e "Recurring Items Complete","Full Log.txt"

rs.open SSql, rec.ActiveConnection, 3
while not rs.EOF
On Error Resume Next
recurring = rs.Fields("urn:schemas:calendar:rrule")
If Err.Number <> 0 Then
	bcontinue = False
End If
On Error Goto 0

	If IsArray(recurring) Then
		e "skipping recurring Item " & rs.Fields("DAV:href").Value,""
	Else
		e smtpMailBox & vbTab & rs.Fields("urn:schemas:httpmail:subject").Value,""
		Call movemessage(rs.Fields("DAV:href").Value,"/" & archiveFolder & "/", boURL & smtpMailBox,Calendar_Folder_Name)
	End If
	
rs.movenext
wend

e "Single Items Complete","Full Log.txt"

rs.close

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

'Move the Item to the Archive folder
Sub movemessage(mSource,mDestFolder,mBoxURL,CalName)
	e mSource & vbtab & mdestFolder & vbtab & mboxurl & vbtab & calname,"Full Log.txt"
	Dim mDest,mRec
	On Error Resume Next
	mDest = Replace(lcase(mSource),"/" & lcase(CalName) & "/",mDestFolder)
	Set mRec = CreateObject("ADODB.Record")
	mRec.Open mBoxURL, ,3
	If Err.Number <> 0 Then 
		e "erro opening URL " & mBoxURL,"Error.Log"
		Err.Clear
	End If
	mRec.MoveRecord mSource, mDest
	If Err.Number <> 0 Then 
		e "Error moving message " & mSource & " to " & mdest,"Error.log"
		Err.Clear
	End If
	mRec.Close
End Sub

'Create Folder if it doesn't already exists
Sub CreateFolder(strFolderUrl)
	Dim nfRec
	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

Function getDefaultFolder(gdfURL,gdfFolder)
	Dim gdfRec,gdfRS,gdfConn,gdfFields
	Set gdfRec = CreateObject("ADODB.Record")
	set gdfRS = CreateObject("ADODB.Recordset")
	Set gdfConn = CreateObject("ADODB.Connection")
	gdfConn.Provider = "ExOLEDB.DataSource"
	gdfRec.Open gdfURL, ,3
	Set gdfFields = gdfRec.Fields
	getDefaultFolder = gdfFields(gdfFolder)
	gdfRec.Close
	gdfConn = ""
	gdfRS = ""
	gdfRec = ""
End Function

Function FindLastWord(flwString,flwDelimiter)
	Dim arSplitVal, inSplitVal
	arSplitVal = Split(flwString, flwDelimiter)
	inSplitVal = UBound(arSplitVal)
	FindLastWord = arSplitVal(inSplitVal)
End Function

Sub e(eLine,eLogFile)
	If eLogFile = "" Then
		WScript.Echo eLine
	Else
		Dim fso, olog
		Set fso = CreateObject("scripting.filesystemobject")
		Set oLog = fso.OpenTextFile(savepath & eLogFile,8,True)
		olog.WriteLine eLine
		olog.Close
		olog = ""
		fso = ""
	End if
End Sub