Find PST files configured in outlook

Robszar,

It looks like your last example is missing come carriage returns and line feeds.  I took the liberty of editing it myself and tested in Windows 7 (64bit)
 

 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 If

End Function 

Wonderfull script. I have added some functions.
Now it's works with:
- unicode file name
- shows the name of file in Outlook
- works with all Outlook profiles
 
 
Option Explicit
'On Error Resume Next
Const HKEY_CURRENT_USER = &H80000001
const HKEY_LOCAL_MACHINE = &H80000002
const KEY_QUERY_VALUE = &H0001
Const r_PSTGuidLocation = "01023d00"
Const r_MasterConfig = "01023d0e"
Const r_PSTCheckFile = "00033009"
Const r_PSTFile = "001f6700"
Const r_PSTNameFile = "001f3001"
Const r_PSTNameFileA = "001f3006"
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, OProfile, errchk, ProfilName, zi


oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName
objPSTLog.WriteLine("Default Profile: "+DefaultProfileName)
objPSTLog.WriteLine("")
objPSTLog.WriteLine("")

errchk = oReg.EnumKey (HKEY_CURRENT_USER,r_DefaultOutlookProfile,OProfile)
IF errchk=0 THEN
For zi = lBound(OProfile) to uBound(OProfile)   
ProfilName=OProfile(zi)
objPSTLog.WriteLine("=== Profile: "+ProfilName+" ===")
GetPSTsForProfile(ProfilName)
objPSTLog.WriteLine("")
objPSTLog.WriteLine("")
Next   
END IF


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, P_PST1, ChkAccess, errcheck
Dim strString:strString = "Name: "

errcheck = oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFile,P_PST1)
IF errcheck=0 THEN
z = lBound(P_PST1)
While z <=uBound(P_PST1)-1
strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
z=z+2
Wend
ELSE
errcheck=oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFileA,P_PST1)
IF errcheck=0 THEN
z = lBound(P_PST1)
While z <=uBound(P_PST1)-1
strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
z=z+2
Wend
END IF
END IF
strString = strString + chr (13)+chr(10)+"   => File Name: "
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
z = lBound(P_PSTName)
While z <=uBound(P_PSTName)-1
strString = strString & ChrW(P_PSTName(z)+256*P_PSTName(z+1))
z=z+2
Wend   
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
'_________________________________________________________________________________________________________

tfairfoul


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 issue and after some error checking my issue appeared to be the fact that key 00033009 with a value of 20 is not unique to PST files ..... I have an ldap address book that uses this value as well.

Thanks so much for this script.
 
Is there any way of writing the output to a network share? I would like to try and incorporate this into a login script, and output each user that logs in to the same network share with their username appended before pst.log.
 
Anyone?

I am trying to set a auto add Calendar event button to complete a form for the new client from an excel doc. Problem I am running into is that the working code does not put the calendar item in the users calendar... I am working on a citrix server and I am not sure how to point this to the individual users name... This is a template that we use with new clients. So several different users will access this, and I want the reminder to be for the user logged in and using the template... the code I am using below is working but only on my home computer and not when I am logged into the citrix server at work. Have any ideas please let me know!
 

   Sub SetAppt() response = MsgBox("Would you like to Schedule a reminder to Complete the OHBH", vbYesNo)

If response = vbNo Then
 MsgBox ("Good Catch!")
 Exit Sub
 
End If

 Dim olApp As Outlook.Application
 Dim olApt As AppointmentItem

 Set olApp = New Outlook.Application
 Set olApt = olApp.CreateItem(olAppointmentItem)

 With olApt
 .Start = Date + 7 + TimeValue("12:00:00")
 .End = .Start + TimeValue("00:30:00")
 .Subject = "Complete OHBH for " + Sheets("Master").Range("B3")
 .Location = "CATT > Bridge Screen"
 .Body = Sheets("Master").Range("B3") + "'s assessment was 7 days ago. You have 3 days to complete the OHBH"
 .BusyStatus = olBusy
 .ReminderMinutesBeforeStart = 120
 .ReminderSet = True
 .Save

 End With

 Set olApt = Nothing
 Set olApp = Nothing

End Sub 

I am missing something?  Is a text file created somewhere where this information is created?