I am attempting to write a script to check for Outlook profiles and find their relavent pst's and write it to a txt. We have some users who have to have 2 seperate profiles and who have to store some pst's on a seperate network share. I did find out script which would work awesomely but only lists the DefaultProfile. I was wondering if anyone knew of a way of doing this in vbscript. For anyone searching here is the script for default profile.
Option Explicit
'On Error Resume Next
Const HKEY_CURRENT_USER = &H80000001
Const r_PSTGuidLocation = "01023d00"
Const r_MasterConfig = "01023d0e"
Const r_PSTCheckFile = "00033009"
Const r_PSTFile = "001f6700"
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 objPSTLog :Set objPSTLog = objFSO.OpenTextFile(ExpandEvnVariable("Temp") & "\pst.log",2,True)
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
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
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
'_____________________________________________________________________________________________________________________________
Function IsAPST(p_PSTGuid)
Dim x, P_PSTGuildValue
Dim P_PSTCheck:P_PSTCheck=0
IsAPST=False
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
If P_PSTCheck=20 Then
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
End Function
'_____________________________________________________________________________________________________________________________
Function PSTFileName(p_PSTGuid)
Dim z, P_PSTName
Dim strString:strString = ""
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))
End If
Next
PSTFileName = strString
Set z = nothing
Set P_PSTName = nothing
End Function
'_________________________________________________________________________________________________________
Function ExpandEvnVariable(ExpandThis)
Dim objWSHShell :Set objWSHShell = CreateObject("WScript.Shell")
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
End Function
'_________________________________________________________________________________________________________
The script you provided in your question contains a function called GetPSTsForProfile
, which takes a profile name and then does its magic to get the PST information. So you've got that part of the puzzle covered.
Now all you need to do is enumerate all profiles. The profiles are stores as subkeys inside HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles
.
Using the terms and variables from the scripts you posted above, here is how to do the enumeration:
Const HKEY_CURRENT_USER = &H80000001
Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
oReg.EnumKey HKEY_CURRENT_USER,r_ProfilesRoot,subKeys
For Each profileName In subKeys
objPSTLog.WriteLine( profileName )
GetPSTsForProfile( profileName )
Next