Find PST files configured in outlook

I have been looking for a way to find the PST files configured in Outlook, couldn't find anything so I figured it out and coded it.. I'm sure this will be helpful to a lot of people.  The output gets written to a txt file in %temp%\pst.log

Enjoy!

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

first impression: Looks nice (will definat. try)...poorly commented though.

I know, I know.. poor commented.....

I usually don't comment my scripts becuase I'm the only one reading them, BUT, the script rocks... 

nice script, just what i was in the process of doing. nice one.

Hi Mate,

Very nice script. I have tried it.
It would be great if we could generate the size of pst file.

Best Regards,


Sympathitekos

fantastic work...im in the process of doing the slight opposite.
 
All of our user PST files are located in the same area on their homedrives i.e
 
if a users logon is ABC, the path would be \\path\ABC\mailsettings 
 
thus, what im trying to do is reverse the conversion of hex data (reg_binary) from a string, prooving to be one hard pain in the ass. Before I go any futher with this, do you know whether this is actually possible?
 
Thanking you

baah asking before doing! ive got a script going...managed to get a way of adding the located pst files to the registry...all i need todo now is convert from ascii to hex using vbs.
 
Dim objNetwork, FSO, pstFolder

Dim strPSTpath, file, pstFiles
 

Set objNetwork = CreateObject("Wscript.Network")
strUser = objNetwork.UserName
strPSTPath = "\\fileserver\"&strUser&"\mailsettings"

 
'get PST filenames.

Set FSO = CreateObject("Scripting.FileSystemObject")

Set pstFolder = FSO.GetFolder(strPSTPath)

Set pstFiles = pstFolder.Files
strRegpath = "HKCU\SOFTWARE\Microsoft\Windows NT\currentVersion\Windows Messaging Subsystem\Profiles\MailProfile\"
 
 

For Each pst in pstFiles
        wscript.echo pst
        'convert to HEX character and place into a registry REG_BINARY KEY.



Next

I've been tasked with writing a script to backup user's PST files so this script was an ideal starting point.  I've tided it up a bit.

 Option Explicit
 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_DefaultProfileString = "DefaultProfile"
 Dim oReg        :Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
 Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
 
 oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
 GetPSTsForProfile(DefaultProfileName)
   
 '_____________________________________________________________________________________________________________________________
 Function GetPSTsForProfile(p_profileName)
     Dim strHexNumber, strPSTGuid, strFoundPST
 
     oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
     For Each i In strValue
         If Len(Hex(i)) = 1 Then 
             strHexNumber = CInt("0") & Hex(i)
         Else
             strHexNumber = Hex(i)
         End If        
         strPSTGuid = strPSTGuid + strHexNumber
         If Len(strPSTGuid) = 32 Then 
             If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
                 Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _
                             PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
             End If    
         strPSTGuid = ""
         End If            
     Next
 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 Each x in P_PSTGuildValue
             P_PSTCheck = P_PSTCheck + Hex(x)
         Next    
         If P_PSTCheck=20 Then
             IsAPST=True
         End If    
 End Function 
 '_____________________________________________________________________________________________________________________________
 Function PSTlocation(p_PSTGuid)
     Dim y, P_PSTGuildValue
     oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
        For Each y In P_PSTGuildValue
            If Len(Hex(y)) = 1 Then
                PSTlocation = PSTlocation & CInt("0") & Hex(y)
            Else
                PSTlocation = PSTlocation & Hex(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 Each z in P_PSTName
             If z > 0 Then strString = strString & Chr(z)
         Next    
     PSTFileName = strString
 End Function 
 '_________________________________________________________________________________________________________
 Function ExpandEvnVariable(ExpandThis)
     Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
     ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
 End Function
 '_________________________________________________________________________________________________________
 
 
 
 

I just found a way to backup open PST files    So now I took the backup out of the login script and moved it to an SMS job that runs during the day....

if you want the hook up send me an email...

I am absolutely convinced that you must be able to get this information using MAPI.

I'm buggered if I can find out how to do it though ;)

HA!  I knew it was possible.

Here's a way to get the information via MAPI.  

 Set objOutlook = CreateObject("Outlook.Application.11")
 Set objNS = objOutlook.GetNamespace("MAPI")
   
 For Each objFolder In objNS.Folders
     If objFolder.Name = "Personal Folders" Then
         Wscript.Echo GetPSTPath(objFolder.StoreID)
     End If
 Next
 
 Function GetPSTPath(input)
 
     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
 

I need to take this script one further. But i'm afraid my knowledge of the registry is limited.
 
Is it possible to modify this to list the PST files on the default mail profile for a remote machine?
 
Sometimes i need to re-profile a user exactly how they had it set up before whatever change it is i've made thats removed their profile. Would be nice to have something that can list them all for me which i can add to a script i have to do a lot of other things :)

if you are going to re-profile a user you will want to do it from their machine, but if their profile is messed up or they are not logged in this script probably would not work. I was thinking of writing a script that gets all profile settings, but there is a couple in Outlook I could not work out so thought it pointless to get some by script but not all.
 
Anyway I hacked on a bit of code I have used in the last couple of my scripts onto to this script to get the PST files in use on a remote machine.
 
Have not tidied it up so it is a bit messy but it works. Basically I added a prompt for remote computer and then find user logged into that machine, then his SID and then changed HKEY_CURRENT_USER everywhere to HKEY_USERS  then query runs on remote machine.
 

 
 

  
 Const HKEY_CURRENT_USER = &H80000001
 Const HKEY_USERS  = &H80000003
 Const r_PSTGuidLocation = "01023d00"
 Const r_MasterConfig = "01023d0e"
 Const r_PSTCheckFile = "00033009"
 Const r_PSTFile = "001f6700"
 Const r_keyMaster = "9207f3e0a3b11019908b08002b2a56c2"
 Const r_DefaultProfileString = "DefaultProfile"
 Dim oReg, strComputer
 Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
 strComputer = inputbox("Enter Remote Computer name to find PST files in use on that computer")
 CU=GetCurrentUser(strComputer)
 CUSID = GetSIDFromUser(CU)
 r_ProfilesRoot = CUSID&"\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
 
 Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_ 
    strComputer & "\root\default:StdRegProv")
 
 oReg.GetStringValue HKEY_USERS,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
 GetPSTsForProfile(DefaultProfileName)
  
 '_____________________________________________________________________________________________________________________________
 Function GetPSTsForProfile(p_profileName)
    Dim strHexNumber, strPSTGuid, strFoundPST
    oReg.GetBinaryValue HKEY_USERS,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
    For Each i In strValue
        If Len(Hex(i)) = 1 Then 
            strHexNumber = CInt("0") & Hex(i)
        Else
            strHexNumber = Hex(i)
        End If        
        strPSTGuid = strPSTGuid + strHexNumber
        If Len(strPSTGuid) = 32 Then 
            If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
                Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _
                            PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
            End If    
        strPSTGuid = ""
        End If            
    Next
 End Function
 '_____________________________________________________________________________________________________________________________
 Function IsAPST(p_PSTGuid)
    Dim x, P_PSTGuildValue
    Dim P_PSTCheck:P_PSTCheck=0
    IsAPST=False
    oReg.GetBinaryValue HKEY_USERS,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue
        For Each x in P_PSTGuildValue
            P_PSTCheck = P_PSTCheck + Hex(x)
        Next    
        If P_PSTCheck=20 Then
            IsAPST=True
        End If    
 End Function 
 '_____________________________________________________________________________________________________________________________
 Function PSTlocation(p_PSTGuid)
    Dim y, P_PSTGuildValue
    oReg.GetBinaryValue HKEY_USERS,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
       For Each y In P_PSTGuildValue
           If Len(Hex(y)) = 1 Then
               PSTlocation = PSTlocation & CInt("0") & Hex(y)
           Else
               PSTlocation = PSTlocation & Hex(y)
           End If    
       Next    
 End Function 
 '_____________________________________________________________________________________________________________________________
 Function PSTFileName(p_PSTGuid)
    Dim z, P_PSTName
    Dim strString : strString = ""
    oReg.GetBinaryValue HKEY_USERS,p_PSTGuid,r_PSTFile,P_PSTName
        For Each z in P_PSTName
            If z > 0 Then strString = strString & Chr(z)
        Next    
    PSTFileName = strString
 End Function 
 '_________________________________________________________________________________________________________
 Function ExpandEvnVariable(ExpandThis)
    Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
    ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
 End Function
 '_________________________________________________________________________________________________________
 Function GetCurrentUser(strComputer) 
 'Input: strComputer = machine to query 
 'Output: Current User as domain\logon 
 'Only works on XP/W2003
    on error resume next
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") 
    Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'explorer.exe'") 
    For Each objProcess in colProcessList 
       objProcess.GetOwner strUserName, strUserDomain 
    Next 
    GetCurrentUser = strUserDomain & "\" & strUserName 
    if err<> 0 then
       Msgbox " Error accessing remote machine"
       wscript.quit
    end if
    on error goto 0
 End Function 
 '-----------------------------------------------------------------------
 Function GetSIDFromUser(UserName) 
 'Input: UserName as domain\logon 
 'Output: SID 
    Dim DomainName, Result, WMIUser 
    If InStr(UserName, "\") > 0 Then 
       DomainName = Mid(UserName, 1, InStr(UserName, "\") - 1) 
       UserName = Mid(UserName, InStr(UserName, "\") + 1) 
    Else 
       DomainName = CreateObject("WScript.Network").UserDomain 
    End If 
    On Error Resume Next 
    Set WMIUser = GetObject("winmgmts:{impersonationlevel=impersonate}!" _ 
       & "/root/cimv2:Win32_UserAccount.Domain='" & DomainName & "'" _ 
          & ",Name='" & UserName & "'") 
    If Err = 0 Then 
       Result = WMIUser.SID 
    Else 
       msgbox "Error retrieving SID"
       wscript.quit
    end if
    On Error GoTo 0 
    GetSIDFromUser = Result 
 End Function 
 '-----------------------------------------------------------------------
  
  
  
 
 

 
 

Ginolard,

I know your entry is a few years old...but...
How the heck did you know that STOREID would return the path to the PST! Its in HEX for a start!!!! MSDN tells you nothing! and you knew to convert it!
Man that was amazing....

Thanks v much.
Mizzy

If I remember rightly, I stumbled across it somehow.  I think I was looking at the outlookcode.com site for a way to do it.

Bringing this back from the dead!

Would it be too much to ask to pull the OST information as well? Of course it would have to tell whether outlook is using cached exchange mode or not!

Could anyone point me in the right direction? thanks all!

Only couple tools has quite facilties for solving this problem, which resembles to mine. One of them I used some years ago and last time it didn't fully help me. Next software has more chances for helping to my mind. It might be useful for other types of problems with ms outlook - fix crc error pst file.

Hi,
  I was wondering if any update is required for this script to work with windows 7 and office 2010. I have used it in the past with xp and office 2003, however I just went to try it with office 2010 on windows 7 and I am getting errors related to Line:
For x = lBound(P_PSTGuildValue) to uBound(P_PSTGuildValue)     
The error I am getting is Type Mismatch: 'lBound'
 
Any thoughts would be helpful.
 
Thanks
 
Todd

I had the same problem you had and I fixed the code as such:

 Option Explicit
 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_DefaultProfileString = "DefaultProfile"
 Dim oReg        :Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
 Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
 
 oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
 GetPSTsForProfile(DefaultProfileName)
 
 '_____________________________________________________________________________________________________________________________
 Function GetPSTsForProfile(p_profileName)
 Dim strHexNumber, strPSTGuid, strFoundPST
 
 oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
 If IsUsableArray (strValue) Then
 For Each i In strValue
 If Len(Hex(i)) = 1 Then 
 strHexNumber = CInt("0") & Hex(i)
 Else
 strHexNumber = Hex(i)
 End If        
 strPSTGuid = strPSTGuid + strHexNumber
 If Len(strPSTGuid) = 32 Then 
 If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
 Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _
 PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
 End If    
 strPSTGuid = ""
 End If            
 Next
 End If
 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
 If IsUsableArray (P_PSTGuildValue) Then
 For Each x in P_PSTGuildValue
 P_PSTCheck = P_PSTCheck + Hex(x)
 Next
 End If
 If P_PSTCheck=20 Then
 IsAPST=True
 End If    
 End Function 
 '_____________________________________________________________________________________________________________________________
 Function PSTlocation(p_PSTGuid)
 Dim y, P_PSTGuildValue
 oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
 If IsUsableArray (P_PSTGuildValue) Then
 For Each y In P_PSTGuildValue
 If Len(Hex(y)) = 1 Then
 PSTlocation = PSTlocation & CInt("0") & Hex(y)
 Else
 PSTlocation = PSTlocation & Hex(y)
 End If    
 Next
 End If
 End Function 
 '_____________________________________________________________________________________________________________________________
 Function PSTFileName(p_PSTGuid)
 Dim z, P_PSTName
 Dim strString : strString = ""
 oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
 If IsUsableArray (P_PSTName) Then
 For Each z in P_PSTName
 If z > 0 Then strString = strString & Chr(z)
 Next
 End If
 PSTFileName = strString
 End Function 
 '_________________________________________________________________________________________________________
 Function ExpandEvnVariable(ExpandThis)
 Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
 ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
 End Function
 '_________________________________________________________________________________________________________
 Function IsUsableArray(rvnt)
'-- Use this function to test for a Null, Empty or an undimensioned array.
'-- Useful b/c some interfaces can hold properties for which if they have a
'-- value will be an Array but may also be Null or an undimensioned Array.

'-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. 
'-- It returns -1 if it is passed a string, long, etc...
'-- It returns 0 for an empty array or the number of elements in the first dimension.

 IsUsableArray = 0
 If (VarType(rvnt) And 8192) = 8192 Then
 IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1
 ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then
 IsUsableArray = -1
 End If
End Function 

I updated the last version with the PST size
 

   Option Explicit 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_DefaultProfileString = "DefaultProfile" Dim oReg        :Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName  oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName GetPSTsForProfile(DefaultProfileName)  '_____________________________________________________________________________________________________________________________ Function GetPSTsForProfile(p_profileName) Dim strHexNumber, strPSTGuid, strFoundPST  oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue If IsUsableArray (strValue) Then For Each i In strValue If Len(Hex(i)) = 1 Then  strHexNumber = CInt("0") & Hex(i) Else strHexNumber = Hex(i) End If         strPSTGuid = strPSTGuid + strHexNumber If Len(strPSTGuid) = 32 Then  If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _ PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)) wscript.echo GetSize(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _ PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))) End If     strPSTGuid = "" End If             Next End If End Function '_____________________________________________________________________________________________________________________________
Function GetSize(zFile) Dim objFSO	:Set objFSO = CreateObject("Scripting.FileSystemObject")dim objFile	:Set objFile = objFSO.GetFile(zFile)GetSize = ConvertSize(objFile.Size)End Function '_____________________________________________________________________________________________________________________________
Function ConvertSize(Size) Do While InStr(Size,",") 'Remove commas from size     CommaLocate = InStr(Size,",")     Size = Mid(Size,1,CommaLocate - 1) & _         Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate) Loop
Dim Suffix:Suffix = " Bytes" If Size >= 1024 Then suffix = " KB" If Size >= 1048576 Then suffix = " MB" If Size >= 1073741824 Then suffix = " GB" If Size >= 1099511627776 Then suffix = " TB" 
Select Case Suffix     Case " KB" Size = Round(Size / 1024, 1)     Case " MB" Size = Round(Size / 1048576, 1)     Case " GB" Size = Round(Size / 1073741824, 1)     Case " TB" Size = Round(Size / 1099511627776, 1) End Select
ConvertSize = Size & Suffix 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 If IsUsableArray (P_PSTGuildValue) Then For Each x in P_PSTGuildValue P_PSTCheck = P_PSTCheck + Hex(x) Next End If If P_PSTCheck=20 Then IsAPST=True End If     End Function  '_____________________________________________________________________________________________________________________________ Function PSTlocation(p_PSTGuid) Dim y, P_PSTGuildValue oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue If IsUsableArray (P_PSTGuildValue) Then For Each y In P_PSTGuildValue If Len(Hex(y)) = 1 Then PSTlocation = PSTlocation & CInt("0") & Hex(y) Else PSTlocation = PSTlocation & Hex(y) End If     Next End If End Function  '_____________________________________________________________________________________________________________________________ Function PSTFileName(p_PSTGuid) Dim z, P_PSTName Dim strString : strString = "" oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName If IsUsableArray (P_PSTName) Then For Each z in P_PSTName If z > 0 Then strString = strString & Chr(z) Next End If PSTFileName = strString End Function  '_________________________________________________________________________________________________________ Function ExpandEvnVariable(ExpandThis) Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell") ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%") End Function '_________________________________________________________________________________________________________ Function IsUsableArray(rvnt)'-- Use this function to test for a Null, Empty or an undimensioned array.'-- Useful b/c some interfaces can hold properties for which if they have a'-- value will be an Array but may also be Null or an undimensioned Array.
'-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. '-- It returns -1 if it is passed a string, long, etc...'-- It returns 0 for an empty array or the number of elements in the first dimension.
 IsUsableArray = 0 If (VarType(rvnt) And 8192) = 8192 Then IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1 ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then IsUsableArray = -1 End IfEnd Function