Move PST files to server via VB - vba

Question

At work we've picked up a new exchange server, so my boss was going to have me go around to all our computers and manually move all the open PST files people had to their folder on the new server. I, for obvious reasons, decided that it would be simpler to script this. After a bit of research I came across one such script that only needed a bit of tweaking (found here http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/) but had a lot of other things I wouldn't really need (checks for if it was running on a laptop, only affecting local folders, etc.), so I cannibalized the main logic out of it into my own version without most of these sanity checks. The problem I'm running into is that I have 2 seemingly identical loops iterating a different number of times, and it causes problems. Here's what I have
Option Explicit
Const OverwriteExisting = True
' get username, will use later
Dim WshNetwork: Set WshNetwork = wscript.CreateObject("WScript.Network")
Dim user: user = LCase(WshNetwork.UserName)
Set WshNetwork = Nothing
' network path to write pst files to
Dim strNetworkPath : strNetworkPath = "\\server\folder\"
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\" End If
' initiate variables and instantiate objects
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFiles, pstName, strPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("c:\My\Desktop\pst_script_log.txt " , True)
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Dim count : count = -1
' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
pstFiles = GetPSTPath(objFolder.StoreID)
pstName = objFolder.Name
count = count + 1
objTextFile.Write(count & " " & pstFiles & vbCrLf)
ReDim Preserve arrNames(count)
arrNames(count) = pstName
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
objOutlook.Session.RemoveStore objFolder
End IF
Next
' closes the outlook session
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
' quits if no pst files were found
If count < 0 Then
wscript.echo "No PST Files Found."
wscript.Quit
End If
objTextFile.Write("moving them" & vbCrLf)
' moves the found pst files to the new location
Dim pstPath
For Each pstPath In arrPaths
On Error Resume Next
objTextFile.Write(pstPath & vbCrLf)
objFSO.MoveFile pstPath, strNetworkPath
If Err.Number <> 0 Then
wscript.sleep 5000
objFSO.MoveFile pstPath, strNetworkPath
End If
Err.Clear
On Error GoTo 0
Next
Set objFSO = Nothing
' sleep shouldn't be necessary, but was having issues believed to be related to latency
wscript.sleep 5000
'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Re-map Outlook folders
For Each pstPath In arrPaths
objTextFile.Write("Remapping " & pstPath & " to " & strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1) & vbCrLf)
objNS.AddStore strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1)
Next
count = -1
For Each objFolder In objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
count = count + 1
objTextFile.Write("Renaming " & GetPSTPath(objFolder.StoreID) & " to " & arrNames(count) & vbCrLf)
objFolder.Name = arrNames(count)
End If
Next
objOutlook.Session.Logoff
objOutlook.Quit
objTextFile.Write("Closing Outlook instance and unmapping obj references...")
Set objFolder = Nothing
Set objTextFile = Nothing
Set objOutlook = Nothing
Set objNS = Nothing
wscript.echo "Done."
wscript.Quit
Private Function GetPSTPath(byVal input)
'Will return the path of all PST files
' Took Function from: http://www.vistax64.com/vb-script/
Dim i, strSubString, strPath
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then
strPath = strPath & ChrW("&H" & strSubString)
End If
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
The offending loop is at lines 24 and 81. The specific error is that count gets incremented more in the second loop than the first, however that's because the first loop is coming up short on its iterations and missing the last PST file. People with similar issues on the site where I found most of this code said that adding in wscript.sleep functions in certain spots helped them, but I've had no such luck in their recommended spots, and I get the impression that their issues are not the same as mine.
I'd greatly appreciate help with what's going wrong in my code, and I'm open to suggestions for ways to correct other issues I don't see, and think there's a better way to do something like this.
EDI:After doing some more research on my issue, it seems that by performing RemoveStore inside the loop at line 24 I'm changing the value of objNS.Folders (which makes sense), and to avoid this I should store the objFolder items I need to remove and do so in another loop. Problem now is that I don't know how to do that, I've tried
[line 35]
ReDim Preserve arrFolders(count)
arrFolders(count) = objFolder
End If
Next
For Each objFolder in arrFolders
objOutlook.Session.RemoveStore objFolder
Next
However I get Type Mismatch errors regarding RemoveStore, so I think it isn't storing the object how it needs to. Any ideas?

Answer 1

FWIW - attaching to PSTs on a network is not supported. See http://support.microsoft.com/kb/297019/en-us and http://blogs.technet.com/b/askperf/archive/2007/01/21/network-stored-pst-files-don-t-do-it.aspx

Answer 2

So, Finally got this working right (or close enough to right). As was mentioned in the comments from Brad, you should search your disk for PST files as well as what I have here. This method ONLY affects PST files that the user has open in Outlook, and NOT all PST files on their computer. What was happening was as I mentioned in my Edit, objOutlook.Session.RemoveStore was changing the value of objNS.Folders, which would break my first For loop. You need to do this outside of your enumartion loop, otherwise it breaks and misses some (as well as mislabels some when remapping them). Also, outside of that loop objFolder needed to be redefined as a MAPIFolder object, or else you get the Type Mismatch errors when trying to remove Working sample is:
' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
count = count + 1
pstFiles = GetPSTPath(objFolder.StoreID)
pstName = objFolder.Name
pstFolder = objFolder
objTextFile.Write(count & " " & pstFiles & vbCrLf)
ReDim Preserve arrNames(count)
arrNames(count) = pstName
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
'objOutlook.Session.RemoveStore objFolder
End If
Next
For Each pstName in arrNames
set objFolder = objNS.Folders.Item(pstName)
objNS.RemoveStore objFolder
Next
set objFolder = Nothing