'************************************************************************
'DESCRIPTION:   Move only archive PSTs to network and reconfigure outlook														
'WRITTEN BY:    Daniel M. Jones											
'DATE:			October 28, 2009											
'COMMENT:		Adopted from move-pst-to-networks by Mark Chamberlain
'************************************************************************

'************************************************************************
' VARIABLE DEFINITION
'************************************************************************

set objFSO = CreateObject("Scripting.FileSystemObject")
set objNetwork = WScript.CreateObject("WScript.Network")
set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")

strUser = lcase(objNetwork.UserName)
strNetworkPath = "c:\temp\archive\" '"\\server\" & strUser & "\OutlookPST\"

'************************************************************************
' FUNCTIONS
'************************************************************************

function getStore(strHexID)
	for i = 1 to len(strHexID) step 2
		strSubString = mid(strHexID, i, 2)
        if (strSubString <> "00") then
            strPath = strPath & chrw("&H" & strSubString)
        end if
    next

    if (inStr(strPath, ":\")) then getStore = mid(strPath, inStr(strPath,":\") - 1)
    if (inStr(strPath, "\\")) then getStore = mid(strPath, inStr(strPath,"\\") - 1)
end function

'************************************************************************
' BEGIN
'************************************************************************

set dicPaths = CreateObject("Scripting.Dictionary")
set dicExcludedPaths = CreateObject("Scripting.Dictionary")
set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")

'Get all PSTs from all Outlook stores.
for each objStore in objNS.Folders
	strStore = getStore(objStore.StoreID)
	strStorePath = left(strStore, inStrRev(strStore, "\"))
	strStoreFile = mid(strStore, inStrRev(strStore, "\") + 1)
	if (objStore.Name = "Archive Folders") then
		set objFiles = objFSO.GetFolder(strStorePath).Files
		for each objFile in objFiles
			if (lcase(right(objFile.Name, 4) = ".pst")) then
				dicPaths.Add objFile.Name, objFile.Path
				if (objFile.Name = strStoreFile) then objOutlook.Session.RemoveStore objStore
			end if
		next
	else
		dicExcludedPaths.Add strStoreFile, strPath
	end if
next

'Exclude non-archive PST paths
for each strKey in dicExcludedPaths.Keys
	if (dicPaths.Exists(strKey)) then
		dicPaths.Remove(strKey)
	end if
next

'kill outlook
objOutlook.Session.Logoff
objOutlook.Quit
set colProcesses = objWMI.ExecQuery("Select * from Win32_Process where Name='OUTLOOK.EXE'")
for each objProcess in colProcesses
	objProcess.Terminate()
next
wscript.sleep 2000


'Copy PST to network and add to new store
set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")
for each strKey in dicPaths.Keys	
	strPath = dicPaths(strKey)
	objFSO.CopyFile strPath, strNetworkPath
	strFileName = mid(strPath, inStrRev(strPath, "\") + 1)
	objNS.AddStore strNetworkPath & strFileName
next	

objOutlook.Session.Logoff
objOutlook.Quit

msgbox "done"