Exporting Mailboxes Larger Than 2 GB On An Exchange Server

''
'' ExMBspanPst.vbs
''
'' Based on a script from Glen Scales
'' http://gsexdev.blogspot.com/2007/01/exporting-mailbox-larger-then-2-gb-and.html
''
'' Requires Outlook Redemption, but not Outlook
'' http://www.dimastr.com/redemption
''
'' Fixes a few bugs:
''	orig. script didn't split at 16K messages in a folder
''	orig. script didn't report progress in 2, 3, ... n PSTs
''	orig. script could create two copies of a message in output PST
''	orig. script didn't send all status output to output file
''	orig. script didn't check for the presence of existing PST
'' Adds a feature or two:
''	accepts input mailbox as parameter
''	a number of stability improvements (error checks)
''	added "option explicit" and updated code for support of same
''	copies HiddenItems (Associated Items) and DeletedItems as well as normal items
'' Almost a full source reformat (so I could understand the code better)
'' Removed a fair bit of unused code (although I may have added more of my own)
'' Release resources whenever possible
'' Use RDO for all things, don't fall back to CDO
''
'' Update published with permission of Glen.
''
'' Michael B. Smith
'' The Essential Exchange
'' michael@TheEssentialExchange.com
''
Option Explicit

Dim mbMailbox      '' name of the mailbox (Exchange alias/mailNickname works best)
Dim servername     '' name of the Exchange server hosting the mailbox
Dim bfbaseFilename '' prefix used to name the new PST
Dim pfFilePath     '' directory in which to store PSTs

mbMailbox = WScript.Arguments(0)
''
'' these should be the only values you need to change
''
servername = "exchserver"
bfBaseFilename = "set1-" & mbMailbox
pfFilePath = "c:\temp\"
''
'' end change area
''

Dim fnFileName '' name of the output PST (set by CreatenewPst; uses pfFilePath, bfBasefileName and mbMailbox)
Dim fNumber    '' index of the output PST (will be updated to start at 1 by CreateNewPst)

fnFileName = ""
fNumber = 0

Dim doDictionaryObject '' scripting.dictionary, contains list of entry-ids present in current PST
Dim fso                '' scripting.filesystemobject
Dim RDOSession         '' redemption.rdosession

Set doDictionaryObject = CreateObject("Scripting.Dictionary")
Set fso                = CreateObject("Scripting.FileSystemObject")
set RDOSession         = CreateObject("Redemption.RDOSession")

Dim tsize       '' the next time I report the size of the new PST (that is, it's calculated size)
Dim tnThreshold '' maximum size (in MB) of a PST, before I switch to a new one

tsize = 10
tnThreshold = 1800

Dim PST
Dim IPMRoot
Dim pfPstFile            '' object for the new PST
Dim PstRootFolder        '' object pointing to the root of the current PST

PST           = Empty    '' PST is the Redemption pointer to the PST
IPMRoot       = Empty    '' IPMRoot is the root of the IPM subtree in the mailbox
pfPstFile     = Empty    '' fso.GetFile(fnFileName) returns the object for this file

PstRootFolder = Empty    '' This variable never actually gets set, but removing it would've
                         '' called for refactoring too much code - when the code is fixed
                         '' to set this value properly, other stuff breaks. That's why the
                         '' return values are commented out in ProcessFolder[Root | Sub].

Dim wfile                '' file we write to for informational messasges
Dim dfDeletedItemsFolder '' the deleted items folder in the current input mailbox
Dim miLoop               '' used for looping through IPMRoot.Folders
Dim fld                  '' used for looping through IPMRoot.Folders
Dim iMessageCount        '' total number of messages processed

iMessageCount = 0

	''
	'' MAIN code
	''

	On Error Resume Next
	Set wfile = fso.opentextfile(pfFilePath & bfBaseFilename & ".txt", 2, true)
	If Err Then
		WScript.Echo "Main: Error: Could not open " & pfFilePath & bfBaseFilename & ".txt"
		WScript.Quit 1
	End If
	On Error Goto 0

	msg "Main: debug output text file is " & pfFilePath & bfBaseFilename & ".txt"
	msg "Main: will attempt login to mailbox " & mbMailbox & " on server " & servername

	RDOSession.LogonExchangeMailbox mbMailbox, servername
	Set dfDeletedItemsFolder = RDOSession.GetDefaultFolder(3)
	Call CreateNewPst

	msg "Main: Enumerating Mailbox " & wscript.arguments(0)

	For miLoop = 1 to IPMRoot.Folders.Count
		Set fld = IPMRoot.Folders(miLoop)
		Call ProcessItems(fld)
		If fld.Folders.count > 0 then
			msg "Main: Calling Enumfolders for " & fld.Name
			Call Enumfolders(fld, PstRootFolder, 2)
		End if
		Set fld = Nothing
	Next

	msg "Main: A total of " & iMessageCount & " messages were processed."
	msg "Main: Done"

	'' clean up and release resources
	Set dfDeletedItemsFolder = Nothing
	RDOSession.Logoff
	wfile.Close
	Set wfile      = Nothing
	Set RDOSession = Nothing
	Set fso        = Nothing

Sub msg(ByVal str)
	WScript.Echo str
	wfile.WriteLine(str)
End Sub

Function Enumfolders(FLDS, RootFolder, ltype)
	''
	'' The current folder in the source mailbox is FLDS
	'' RootFolder should be the parent folder of the current folder
	''
	'' If ltype == 2, then process the non-folder items in the current folder (i.e., messages)
	'' If ltype == 1, then process the sub-folders in the current folder
	''
	Dim fl  '' used for looping through FLDS.Folders
	Dim fld '' used for looping through FLDS.Folders

	For fl = 1 to FLDS.Folders.count
		Set fld = FLDS.Folders(fl)
		If ltype = 1 then
			Call ProcessFolderSub(fld, RootFolder)
		Else
			Call ProcessItems(fld)
		End If

		msg "Enumfolders: " & fld.Name

		If fld.Folders.Count <> 0 then
			Call Enumfolders(fld, fld.EntryID, ltype)
		End if
		Set fld = Nothing
	Next
End function

Function CreateNewPst
	''
	'' conceivably, we should check ERR.number for almost every statement in this routine
	'' realistically, that would make the code almost unreadable and incomprehensible
	''
	Dim pstfld '' used for looping through PstRoot.Folders
	Dim fiLoop '' used for looping through IPMRoot.Folders
	Dim fld    '' used for looping through IPMRoot.Folders

	doDictionaryObject.RemoveAll
	fNumber = fNumber + 1
	fnFileName = pfFilePath & bfBaseFilename & "-" & fNumber & ".pst"

	msg "CreateNewPst: About to create new PST named " & fnFileName

	If fso.FileExists(fnFileName) Then
		msg "CreateNewPst: Error: PST already exists: " & fnFileName
		WScript.Quit 1
	End If

	If Not IsEmpty(PST) Then
		Set PST = Nothing
	End If
	Set PST = RDOSession.Stores.AddPSTStore(fnFileName, 1,  "Exported MailBox-" & now())

	If fnumber = 1 Then
		Dim pstroot

		Set pstroot = RDOSession.GetFolderFromID(PST.IPMRootFolder.EntryID, PST.EntryID)
		For Each pstfld In PstRoot.folders
			If pstfld.Name = "Deleted Items" Then
				doDictionaryObject.add dfDeletedItemsFolder.EntryID, pstfld.EntryID
				msg "CreateNewPst: Added Deleted Items Folder to dictionary"
				Exit For
			End If
		Next
		Set pstroot = Nothing
	End If

	If Not IsEmpty(IPMRoot) Then
		Set IPMRoot = Nothing
	End If
	Set IPMRoot = RDOSession.Stores.DefaultStore.IPMRootFolder

	msg "CreateNewPST: processing each new default folder in new PST"
	For fiLoop = 1 to IPMRoot.Folders.count
		Set fld = IPMRoot.Folders(fiLoop)
		If fld.Name <> "Deleted Items" Then
			PstRootFolder = ProcessFolderRoot(fld, PST.IPMRootFolder.EntryID)
		End If
		If fld.Folders.count > 0 Then
			Call Enumfolders(fld, fld.EntryID, 1)
		End If
		Set fld = Nothing
	Next

	If Not IsEmpty(pfPstFile) Then
		Set pfPstFile = Nothing
	End If
	Set pfPstFile = fso.GetFile(fnFileName)

	tsize = 10 '' back at the beginning now

	msg "CreateNewPst: Created new PST named: " & fnFileName
End Function

Function ProcessFolderRoot(Fld, parentfld)
	Dim newFolder '' next folder to be examined
	Dim CDOPstFld '' a particular folder parent in the PST based on the entryid of the PST

	msg "ProcessFolderRoot: " & fld.Name

	Set CDOPstfld = RDOSession.GetFolderFromID(parentfld, PST.EntryID)
	Set newFolder = CDOPstfld.Folders.ADD(Fld.Name)	
	'''ProcessFolderRoot = newFolder.EntryID
	newfolder.fields(&H3613001E) = Fld.fields(&H3613001E)

	doDictionaryObject.add Fld.EntryID, newfolder.EntryID

	Set newFolder = Nothing
	Set CDOPstfld = Nothing
End Function

Function ProcessFolderSub(Fld, parentfld)
	Dim newFolder '' next folder to be examined
	Dim CDOPstFld '' a particular folder parent in the PST based on the entryid of the PST

	msg "ProcessFolderSub: " & fld.Name

	Set CDOPstfld = RDOSession.GetFolderFromID(doDictionaryObject.item(parentfld), PST.EntryID)
	Set newFolder = CDOPstfld.Folders.ADD(Fld.Name)	
	'''ProcessFolderSub = newFolder.EntryID
	newfolder.fields(&H3613001E) = Fld.fields(&H3613001E)

	doDictionaryObject.add Fld.EntryID, newfolder.EntryID

	Set newFolder = Nothing
	Set CDOPstfld = Nothing
End Function

Sub ReportError(prefix, Fld, item, txt)
	msg prefix & " " & "Error Processing Item #" & item & " in " & Fld.Name & " " & txt
	msg prefix & " " & "EntryID of Item: " & Fld.items(item).EntryID
	msg prefix & " " & "Subject of Item: " & Fld.items(item).Subject
End Sub

Function CalcNewSize(pstFile, item)
	''
	'' calculate what the new physical size of the pstFile will be after adding the next item
	'' to it. do so safely, avoiding all possible faults, and return the value in megabytes,
	'' rounded up.
	''
	Dim pstSize, itemSize, totalSize

	On Error Resume Next
	pstSize = pstFile.Size
	If Err.Number Then
		pstSize = 1048576 '' assume 1 MB for the heck of it
	End If

	Err.Clear
	itemSize = item.Size
	If Err.Number Then
		itemSize = 1048576 '' assume 1 MB for the heck of it
	End If

	Err.Clear
	totalSize = Int ((pstsize + itemSize) / 1048576) + 1
	If Err.Number Then
		totalSize = 3
	End If
	On Error Goto 0

	CalcNewSize = totalSize
End Function	

Sub ProcessItems(Fld)
	Dim strType             '' the IPM type of the input folder
	Dim fiItemLoop          '' used to loop through the input folder
	Dim fiCDOcount          '' how many messages CDO told us to expect
	Dim pfPredictednewSize  '' predicted size of the output PST after the next message is written
	Dim dfDestinationFolder '' output folder in the current output PST
	Dim objMessages         '' collection of messages contained by the source folder
	Dim objMessage	        '' current message of interest from the source folder
	Dim srcFld              '' the source folder
	Dim strName             '' name of the source folder
	Dim i                   '' used as a dummy
	Dim iCount              '' how many messages have been stored in the output folder
	Dim totalMessagesRead
	Dim totalMessagesWritten

	iCount = 0
	totalMessagesRead = 0
	totalMessagesWritten = 0

	Const iCountmax = 16300 '' must be less than 16383, which is the number of messages that CAN be stored
                                '' per output folder in an ANSI PST

	strtype = Fld.fields(&H3613001E)

	'''' frankly, I don't understand the distinction below, it was in the
	'''' original code, but the two should be equivalent.
	If strType = "IPF.Contact" Then
		Set srcFld = Fld
	Else
		Set srcFld = RDOSession.GetFolderFromID(Fld.EntryID)
	End If
	strName = srcFld.Name

	For i = 1 to 3
		''' there are 3 collections in every folder that we might be interested in
		Select Case i
			Case 1
				Set objMessages = srcFld.Items
				msg "ProcessItems: " & strType & ": Processing Folder: " & strName & _
					" (contains " & objMessages.Count & " normal items)"
			Case 2
				Set objMessages = srcFld.HiddenItems
				msg "ProcessItems: " & strType & ": Processing Folder: " & strName & _
					" (contains " & objMessages.Count & " hidden/associated items)"
			Case 3
				Set objMessages = srcFld.DeletedItems
				msg "ProcessItems: " & strType & ": Processing Folder: " & strName & _
					" (contains " & objMessages.Count & " deleted items)"
		End Select

		fiCDOcount = objMessages.Count

		Set dfDestinationFolder = RDOSession.GetFolderFromID(doDictionaryObject.item(Fld.EntryID), PST.EntryID)

		For fiItemloop = 1 to fiCDOcount
			iCount            = iCount + 1
			totalMessagesRead = totalMessagesRead + 1

			If 0 = (fiItemLoop Mod 100) Then
				wscript.echo "... processing message " & fiItemLoop & " of " & fiCDOcount
			End If

			'' I SO wish VBScript had a Continue statement
			On Error Resume Next
			Err.Clear
			Set objMessage = objMessages(fiItemLoop)
			If Err.Number <> 0 Then
				msg "ProcessItems: corrupt message in folder, item number " & fiItemLoop & _
					" of " & fiCDOcount & ", 0x" & _
					Hex(Err.Number) & " (" & Err.Description & ")"
			Else
				On Error Goto 0

				pfPredictednewSize = CalcnewSize(pfPstFile, objMessage)
				If pfPredictednewSize >= tsize Then
					Wscript.echo "... additional 10 MB Exported, total size is now " & tsize & " MB" & _
						" (processing item #" & fiItemLoop & " of " & fiCDOcount & ")"
					tsize = tsize + 10
				End if

				If (pfPredictednewSize >= tnThreshold) or (iCount > iCountmax) Then
					msg "ProcessItems: " & strType & ": New PST about to be created - Destination - Number of Items : " & _
						dfDestinationFolder.Items.Count & _
						" (processing item #" & fiItemLoop & " of " & fiCDOcount & ")"

					Call CreateNewPst
					Set dfDestinationFolder = Nothing
					Set dfDestinationFolder = RDOSession.GetFolderFromID(doDictionaryObject.item(Fld.EntryID), PST.EntryID)

					iCount = 0
				End If

				On Error Resume Next
				Err.Clear
				objMessage.CopyTo(dfDestinationFolder)
				If Err.Number <> 0 Then
					Dim rdosrc

					Call ReportError ("ProcessItems: " & strType & ":", Fld, fiItemloop, "(copyto - likely fatal)")
					msg "ProcessItems: 0x" & Hex(Err.Number) & ": " & Err.Description
					Err.Clear

					''' Try to copy a slightly different way before giving up
					Set rdosrc = RDOSession.GetMessageFromID(objMessage.EntryId)
					rdosrc.CopyTo(dfDestinationFolder)
					If Err.Number <> 0 Then
						msg "ProcessItems: " & strType & ": (copyto): Also Failed RDO Copy"
						msg "ProcessItems: 0x" & Hex(Err.Number) & ": " & Err.Description
					Else
						msg "ProcessItems: " & strType & ": (copyto): Copied with RDO Okay"
						totalMessagesWritten = totalMessagesWritten + 1
					End If
					Set rdosrc = Nothing
				Else
					totalMessagesWritten = totalMessagesWritten + 1
				End If
			End If
			On Error Goto 0

			Set objMessage = Nothing
		Next
	Next

	msg "ProcessItems: " & strType & ": Source - Number of Items : " & totalMessagesRead & _
	    " Destination - Number of Items : " & totalMessagesWritten

	iMessageCount     = iMessageCount + totalMessagesRead

	Set dfDestinationFolder = Nothing
	Set objMessages         = Nothing
	Set srcFld              = Nothing
End Sub