• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1084
  • Last Modified:

VB script to find PST files Works with Outlook 2003 & 2007 but not 2010?

Hi I found the following code on the Internet & it works for Outlook 2003 & 2007 on Windows XP.  I also need to it work with Outlook 2010, but it errors with a VBScript runtime error: Object not a collection (43, 10)

Can anyone help with updating this code so that it works with 2010 as well please?
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

Open in new window

0
coch
Asked:
coch
  • 2
2 Solutions
 
x-menIT super heroCommented:
thats because the registry hive is diferent in Outlook 2010.

this will explain everything: http://gsexdev.blogspot.com/2010/10/modifying-outlook-profiles-in-outlook.html
0
 
cochAuthor Commented:
Using this just for Pre Outlook 2010 clients.  For 2010 I'm now using the following

Set oFS = CreateObject("Scripting.FileSystemObject")
Set wshNetwork = WScript.CreateObject( "WScript.Network" )
strComputerName = wshNetwork.ComputerName
strUserName = wshNetwork.UserName
outfile = "H:\MyLocalPsts.txt"
Set oTF = oFS.CreateTextFile (outfile)
Search("c:\")
oTF.Close

Function Search(path)
      On Error Resume Next
      Set oFolder = oFS.GetFolder(path)
      For Each folder In oFolder.SubFolders
            Search(folder.path)
      Next
      For Each file In oFolder.Files
          If Right(LCase(File.name),4) = ".pst" Then
                oTF.writeline(File.Path)
'                oTF.WriteLine(File.DateLastModified)
'                oTF.WriteLine(File.Size / 1024 & "KB" & VbCrLf)
          End If
      Next
End Function
0
 
cochAuthor Commented:
Created new script for 2010 clients not based on the original regisrty search
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now