This is my modified script from [link=showprofile.aspx?memid=6118]robszar.[/link]
I used this to migrate office 2003 to office 2007, and to change the pst locations from c: to d: drive. I used the office 2003 profile wizard to backup and restore the settings. But the issue was the location of the pst files and ost files changed. So I needed a script which can read and write the pst locations from registry. Also password protected pst files can be migrated without errors.
Const HKEY_CURRENT_USER = &H80000001
Const r_PSTGuidLocation = "01023d00"
Const r_MasterConfig = "01023d0e"
Const r_MasterConfig1 = "01023d00"
Const r_PSTCheckFile = "00033009"
Const r_PSTFile = "001f6700"
'Const r_PSTFile = "01020fff"
Const r_keyMaster = "9207f3e0a3b11019908b08002b2a56c2"
Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const r_DefaultOutlookProfile = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const r_DefaultProfileString = "DefaultProfile"
Dim oReg :Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim objFSO :Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
Set network = Wscript.createobject("Wscript.network")
Set sh = Wscript.CreateObject("Wscript.Shell")
username = network.username
Dim objPSTLog :Set objPSTLog = objFSO.OpenTextFile("c:\users\" & username & "\pst.log",2,True)
strold = "d:\documents and settings\" & username & "\exchange"
strnew = "C:\Users\" & username & "\Documents\Mail"
oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName
objPSTLog.WriteLine(DefaultProfileName)
GetPSTsForProfile(DefaultProfileName)
objPSTLog.close
Set objPSTLog = Nothing
'_____________________________________________________________________________________________________________________________
Function GetPSTsForProfile(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
'MsgBox r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid
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))
strLocPST = PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
' MsgBox r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)
'MsgBox LCase(strLocPST)
If Not InStr(LCase(strLocPST), "sharepoint lists.pst") <> 0 Then
StrRegKey = r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)
strWriteKey = strLocPST & ";" & strRegKey
WriteNewLocation(strWriteKey)
End If
End If
HexCount = 0
strPSTGuid = ""
End If
Next
'GetPSTsForProfile = strFoundPST
End Function
'_____________________________________________________________________________________________________________________________
Function IsAPST(p_PSTGuid)
Dim x, P_PSTGuildValue
Dim P_PSTCheck:P_PSTCheck=0
IsAPST=False
On Error Resume Next
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue
For x = lBound(P_PSTGuildValue) to uBound(P_PSTGuildValue)
P_PSTCheck = P_PSTCheck + Hex(P_PSTGuildValue(x))
Next
'MsgBox P_PSTCheck
If P_PSTCheck=20 Then
P_PSTCheck
IsAPST=True
End If
End Function
'_____________________________________________________________________________________________________________________________
Function PSTlocation(p_PSTGuid)
Dim y, P_PSTGuildValue, t_strHexNumber
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
For y = lBound(P_PSTGuildValue) to uBound(P_PSTGuildValue)
If Len(Hex(P_PSTGuildValue(y))) = 1 Then
PSTlocation = PSTlocation + "0" & Hex(P_PSTGuildValue(y))
Else
PSTlocation = PSTlocation + Hex(P_PSTGuildValue(y))
End If
Next
'MsgBox PSTlocation
End Function
'_____________________________________________________________________________________________________________________________
Function PSTFileName(p_PSTGuid)
Dim z, P_PSTName
Dim strString:strString = ""
'HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Default Outlook Profile\binairy_data_01023d00,001f6700,
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
For z = lBound(P_PSTName) to uBound(P_PSTName)
If P_PSTName(z) > 0 Then
strString = strString & Chr(P_PSTName(z))
'MsgBox Chr(P_PSTName(z))
End If
Next
PSTFileName = strString
Set z = nothing
Set P_PSTName = nothing
End Function
'_________________________________________________________________________________________________________
Function WriteNewLocation(strWriteKey)
strSplitter = Split(strWriteKey, ";", -1, 1)
PSTFileNameOld = LCase(strSplitter(0))
p_PSTRGuidReg = strSplitter(1)
objPSTLog.WriteLine(p_PSTRGuidReg)
'MsgBox PSTFileNameOld
If InStr(PSTFileNameOld,strold) <> 0 Then
BinaryValueName = Replace(PSTFileNameOld,strold,strnew)
End If
'MsgBox p_PSTRGuidReg
'MsgBox r_PSTFile
'MsgBox "now fixing " & BinaryValueName
objPSTLog.WriteLine "Now fixing " & BinaryValueName
max = len(BinaryValueName)
For intLoop = 1 to max step 1
asciiName = asc(mid(BinaryValueName, intLoop, 1))
if newAsciiName = "" and newAsciiInitials = "" Then
newAsciiName = asciiName
'newAsciiInitials = asciiName
else
newAsciiName = newAsciiName & "," & "00" & "," & asciiName
end if
If intLoop <= 2 then
newAsciiInitials = newAsciiName & "," & "00"
End If
Next
newAsciiName = newAsciiName & "," & "00," & "00," & "00"
'MsgBox newAsciiName
strBinaryValueName = Split(newAsciiName,",")
strMoniker = "winMgmts:\\.\root\default:StdRegProv"
Set oReg1 = GetObject(strMoniker)
strPSTEnd = oReg1.SetBinaryValue(HKEY_CURRENT_USER, strSplitter(1), r_PSTFile, StrBinaryValueName)
On Error Resume Next
objPSTLog.WriteLine "Deleting key: HKEY_CURRENT_USER\" & strSplitter(1) & "\01020fff"
sh.regdelete "HKEY_CURRENT_USER\" & strSplitter(1) & "\01020fff"
End If
End Function
'__________________________________________________________________________________________________________
Function ExpandEvnVariable(ExpandThis)
Dim objWSHShell :Set objWSHShell = CreateObject("WScript.Shell")
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
End Function