Using VBScript List Out All Outlook Profiles and PST's

Question

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 
 '_________________________________________________________________________________________________________ 

Answer 1

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

Answer 2

For Outlook 2013, the registry key has change. You will be able to find the profiles in

HKCU\Software\Microsoft\Office\15.0\Outlook\Profiles

c#.net

string profilesRoot = "Software\\Microsoft\\Office\\15.0\\Outlook\\Profiles";
Registry.CurrentUser.OpenSubKey(profilesRoot).GetSubKeyNames()