Scripting: Listing PST files in an outlook profile

One of my clients was in a nasty situation, he had a ton of users with PST files on the fileserver and they wanted that changed. Understandable as it is an unsupported situation Smile. Now the real problem is that every option we went over required a ton of manual labor which, in an environment of 20 000 mailboxes with hot desks, was not an option. So with the clients requirements in hand I created a vbs script which would work for all of their workstations (running different OS and outlook versions –_- ) and could be used to collect data on where the PST files are located….

Dim objNetworkSet, objFSO, objFolder, objShell, objTextFile, objFile, objWMISysEnv,ObjItem, objTextFileUNC
Dim strHomePath, strDirectory, strFile, strText, strComputerName,strDirectoryUNC,strFileUNC
dim colItems
Set objNetwork = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = WScript.CreateObject("WScript.Shell")
' Setting file names
strDirectory = "c:\users\marcdek\temp"
strFile = "\" & ObjNetwork.Username &"-PSTOUTPUT.txt"
' Check to see if the file already exists exists
If objFSO.FolderExists(strDirectory) Then
   Set objFolder = objFSO.GetFolder(strDirectory)
   Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
   Set objFolder2 = objFSO.GetFolder(strDirectory)
   Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
End If 
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
' Opening text file
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
Set objTextFileUNC= objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
' Here we go!
For Each objFolder2 In objNS.Folders
 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)
    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
If err.number = vbEmpty then
  Else WScript.echo "VBScript Error: " & err.number
End If
Comments (9)

  1. Anonymous says:

    Great script… but..
    I have a need to:-
    connect any new users to a particular Windows 7 Pro (outlook 2007) machine to ALL PST files within C:Outlook*.pst
    could I be cheeky and ask for assistance on this one please? the computer – due to restrictions – is NOT part of a domain. and I am an administrator.
    Many Thanks

  2. sk says:

    please correct me if i am wrong, but isn't this script the same as the one posted here:…/scripting-adding-pst-files-to-an-outlook-profile-automatically.aspx

    to add the PSTs to the Outlook profile?

    Also, there is a PST discovery tool that was recently rolled out by MS to perform these steps through a GUI – PST Capture…/details.aspx

  3. On the PST Discovery tool: This script only lists the PSTs. The client in question wanted to keep pst files in place but know where they were and move them to local discs.

  4. Marc says:

    XOUser8334, have a look at this one:

    With some adaptation it should be possible to get a list of all files with a PST extension and connect them in to outlook

  5. noob2 says:

    can u please tell me which part that need to modify to make this script work at my pc?

  6. Graeme says:

    Thanks for the script, have used it (modified slightly) and it works well. Thanks for sharing. couple of comments though… The line "Set objFile = objFSO.CreateTextFile(strDirectory & strFile)" that creates a new file if the output file doesn’t exist
    holds the file locked so that the line fails with access denied the first time the script runs. The first line is in fact completely unnecessary as the later command will create the file if it doesn’t exist. Otherwise you should have objFile.close after creating
    the file. Also the script produces several blank lines in the output folder which is a minor annoyance, but can be filtered out using Trim. The output file is constantly appended to, not updated. So if you were to use this in a login script for example you
    would quickly have the same PST’s listed over and over (Change for ForAppending to ForWriting to change this) noob: there are several changes that are necessary to make this work on a local PC. change the line strDirectory = "c:usersmarcdektemp" so that
    the path is where you want to save the txt file find and delete the following lines entirely: strDirectoryUNC= strFileUNC= ———— If objFSO.FileExists(strDirectory & strFile) Then Set objFolder2 = objFSO.GetFolder(strDirectory) Else Set objFile = objFSO.CreateTextFile(strDirectory
    & strFile) End If ———— objTextFileUNC.WriteLine(GetPSTPath(objFolder2.StoreID))

  7. abaig says:

    I am getting this error when I run this VB script.
    Microsoft VBScript runtime error: ActiveX component can’t createobject: ‘Outlook.Application’ Please advice what I am doing wrong.

  8. Evg1 says:

    Thanks for script. But i have a problem with output file characters. Russian letters in that file shows corrupted like "C:UsersevgDocuments$09;K Outlookarchive.pst" Plz! help resolve this problem! or maybe some advise help

Skip to main content