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

Posted on 2011-05-04
Last Modified: 2012-05-11
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 
 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) 
             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             
 End Function 
 Function IsAPST(p_PSTGuid) 
     Dim x, P_PSTGuildValue 
     Dim P_PSTCheck:P_PSTCheck=0 
     oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue 
         For Each x in P_PSTGuildValue 
             P_PSTCheck = P_PSTCheck + Hex(x) 
         If P_PSTCheck=20 Then 
         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) 
                PSTlocation = PSTlocation & Hex(y) 
            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 
         For Each z in P_PSTName 
             If z > 0 Then strString = strString & Chr(z) 
     PSTFileName = strString 
 End Function  
 Function ExpandEvnVariable(ExpandThis) 
     Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell") 
     ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%") 
 End Function

Open in new window

Question by:coch
    LVL 18

    Accepted Solution

    thats because the registry hive is diferent in Outlook 2010.

    this will explain everything:

    Assisted Solution

    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)

    Function Search(path)
          On Error Resume Next
          Set oFolder = oFS.GetFolder(path)
          For Each folder In oFolder.SubFolders
          For Each file In oFolder.Files
              If Right(LCase(,4) = ".pst" Then
    '                oTF.WriteLine(File.DateLastModified)
    '                oTF.WriteLine(File.Size / 1024 & "KB" & VbCrLf)
              End If
    End Function

    Author Closing Comment

    Created new script for 2010 clients not based on the original regisrty search

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    IT, Stop Being Called Into Every Meeting

    Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

    This script will sweep a range of IP addresses (class c only, and report to a log the version of office installed. What it does: 1.)      Creates log file in the directory the script is run from (if it doesn't already exist) 2.)      Sweep…
    This is pretty cool.  The purpose of this VB Script is to help you document where JAR (Java ARchive) files and specifically java class files are located so that you can address issues seen with a client or that you can speak intelligently with a dev…
    Migrating to Microsoft Office 365 is becoming increasingly popular for organizations both large and small. If you have made the leap to Microsoft’s cloud platform, you know that you will need to create a corporate email signature for your Office 365…
    This video is in connection to the article "The case of a missing mobile phone (". It will help one to understand clearly the steps to track a lost android phone.

    759 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    11 Experts available now in Live!

    Get 1:1 Help Now