Find PST files configured in outlook

Re:Find PST files configured in outlook (girt0n)

Wed, 11 Jan 2012 11:00:03 GMT

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

Re:Find PST files configured in outlook (DMaCATO)

Fri, 18 Nov 2011 08:14:05 GMT

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?

Re:Find PST files configured in outlook (NHS_newVBer)

Thu, 03 Nov 2011 17:22:52 GMT

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.

RE: Find PST files configured in outlook (trolrolo)

Sat, 24 Sep 2011 02:27:43 GMT

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

Re:Find PST files configured in outlook (kingdc)

Tue, 09 Aug 2011 04:56:24 GMT

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

Re:Find PST files configured in outlook (robszar)

Tue, 24 May 2011 13:23:12 GMT

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

Re:Find PST files configured in outlook (Nomi1985)

Sun, 22 May 2011 12:57:53 GMT

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

Re:Find PST files configured in outlook (tfairfoul)

Fri, 06 May 2011 13:51:55 GMT

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

Re:Find PST files configured in outlook (zlatan24)

Fri, 18 Mar 2011 13:44:04 GMT

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.

RE: Find PST files configured in outlook (rfrye123)

Wed, 22 Sep 2010 15:07:13 GMT

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!

RE: Find PST files configured in outlook (ginolard)

Thu, 15 Oct 2009 04:23:44 GMT

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.

RE: Find PST files configured in outlook (mizzy)

Tue, 28 Jul 2009 03:39:47 GMT

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

RE: Find PST files configured in outlook (TomRiddle)

Thu, 24 Jul 2008 23:21:49 GMT

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

RE: Find PST files configured in outlook (L4suicide)

Mon, 30 Jun 2008 02:45:57 GMT

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 :)

RE: Find PST files configured in outlook (ginolard)

Wed, 27 Jun 2007 23:12:15 GMT

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

RE: Find PST files configured in outlook (ginolard)

Fri, 15 Jun 2007 05:52:41 GMT

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 ;)

RE: Find PST files configured in outlook (robszar)

Fri, 15 Jun 2007 05:33:47 GMT

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...

RE: Find PST files configured in outlook (ginolard)

Fri, 15 Jun 2007 01:39:35 GMT

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

RE: Find PST files configured in outlook (chong)

Wed, 02 May 2007 04:30:55 GMT

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

RE: Find PST files configured in outlook (chong)

Wed, 02 May 2007 02:24:53 GMT

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