Move pst file problem

[Neo2102]

Hello,

I need to move PST from all profile to new location and I need to Enumerate all user mounted PST.
This script work really great but the problem it's with PST file with password... This script prompt for PST password and stop.
This script need to be run on LogonScript so what I want is,

Enumerate all pst and move it to new location
remount all pst file from new location exept for pst with password... For pst with password I'll do it manually

So :

1) Enumerate All pst mounted in Outlook.
2) Move all mounted pst to new location (including pst with password)
3) remount all pst from new location exept for pst with password of course.
4) Create log file and add pst who cannnot be remounted due to password.

This script below work great exept when I have pst with password ... When I launch script outlook ask for PST file password and I don't want that...

I need : Be default move all pst to new location and only remount pst without password and create logfile with pst who is not sucessfully mounted due to password

Who can help me please ?


I use this script :

Option Explicit
Const OverwriteExisting = True
Set wshShell = WScript.CreateObject ("WSCript.shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim WshNetwork : Set WshNetwork = WScript.CreateObject("WScript.Network")
Dim user : user = (WshNetwork.UserName)
Dim wshShell, FSO, strDirectory
strDirectory = "C:\Documents and Settings\"&user&"\My Pst"
'WshShell.run "E:\Send-Enter.vbs"
If Not FSO.FolderExists(strDirectory) Then
FSO.CreateFolder(strDirectory)
End If
If Not FSO.FileExists("C:\Move-PST-TO-W.log") Then
WshShell.run "subst W: ""C:\Documents and Settings\"&user&"\My Pst"""
wscript.sleep 5000
' network path to write pst files to
Dim strNetworkPath : strNetworkPath = "W:\"

' initiate variables and instantiate objects
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFiles, pstName, strPath, pstFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("C:\Move-PST-TO-W.log" , True)
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Dim count : count = -1

' Enumerate PST filesand build arrays
On Error Resume Next
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

' 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
On Error Resume Next
Dim pstPath
For Each pstPath In arrPaths
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
WScript.Sleep 60000

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
Function GetPSTPath(p_profileName)
Dim strHexNumber, strPSTGuid, strFoundPST
Dim HexCount :HexCount = 0

oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
For i = lBound(strValue) to uBound(strValue)
If Len(Hex(strValue(i))) = 1 Then
strHexNumber = "0" & Hex(strValue(i))
Else
strHexNumber = Hex(strValue(i))
End If
strPSTGuid = strPSTGuid + strHexNumber
HexCount = HexCount + 1
If HexCount = 16 Then
If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
'wscript.echo vbCrLf & "PST FOUND: " & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)
'strFoundPST = strFoundPST & "??" & PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
objPSTLog.WriteLine(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)))
End If
HexCount = 0
strPSTGuid = ""
End If
Next
'GetPSTsForProfile = strFoundPST
End Function
Else
WScript.Echo "Script has been already launched. Exiting !"
WScript.Quit
End If