Find PST in Outlook Profiles with VBS Script

Andres Bohren

2014-11-09

Hallo zusammen,

Vor ein paar Wochen habe ich ein VBS Script geschrieben um PST's in Outlook Profilen zu loggen. Dieses Script hat uns geholfen um die Anzahl der PST's zu bestimmen und daraus den besten Migrationsweg abzuleiten.

Eigentlich wollte ich das Script zuerst aufgrund von folgendem Script anpassen. Es hat sich jedoch als eher unzuverlässig erwiesen, da das Timing vom starten und beenden des Outlook.Application Objekts ziemlich schwierig war. Deshalb habe ich mich dazu entschieden nur die Registry zu durchsuchen. Das ist viel schneller und ausserdem zuverlässig.

Funktioniert prima für Outlook 2007 / Outlook 2010. Bei Outlook 2013 werden die Daten nicht mehr gleich in die Registry geschrieben. Deshalb funktioniert das Script für Outlook 2013 nicht.

'###############################################################################
'# List Profiles and PST from Outlook
'# Uses Outlook Search or Remove PST Files from Profile
'# 15.09.2014 v1.0 Initial Version - Andres Bohren
'# 30.09.2014 v1.1 Script rewritten to Scan only Registry
'# http://blog.icewolf.ch / a.bohren@icewolf.ch
'###############################################################################

Option Explicit
On Error Resume Next

'#Declaration
Dim strUsername,strUserdomain,strComputername,strSystemCaption,strSystemVersion,strSystemLocale,strOsType,strProfilename,strDefaultProfile,strPSTFilepath, strPickLogonProfile

'#SystemInfo
Dim oWshShell
Set oWshShell = WScript.CreateObject("WScript.Shell")

'#Hostname, Domain, Username
Dim WshNetwork
Set WshNetwork = WScript.CreateObject("WScript.Network")
'Msgbox "Hostname: " & WshNetwork.ComputerName & " User: " & WshNetwork.Userdomain & "\" & WshNetwork.UserName
strUsername = WshNetwork.UserName
strUserdomain = WshNetwork.Userdomain
strComputername = WshNetwork.ComputerName

'#OS, Version, Locale
Dim System,Systemset
Set SystemSet = GetObject("winmgmts:").InstancesOf ("Win32_OperatingSystem")
for each System in SystemSet
'WScript.Echo System.Caption
'WScript.Echo " Version: " + System.Version
'WScript.Echo " Locale: " + System.Locale
'http://msdn.microsoft.com/de-ch/goglobal/bb895996.aspx
'0807 German_Swiss
'100c French_Swiss
'0810 Italian_Swiss

strSystemCaption = System.Caption
strSystemVersion = System.Version
strSystemLocale = System.Locale
next

'#x86 / x64
strOsType = oWshShell.RegRead("HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\PROCESSOR_ARCHITECTURE")

'#DefaultProfile
strDefaultProfile = oWshShell.RegRead("HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\DefaultProfile")
'If strDefaultProfile <> "" then
' MsgBox ("Default: " & strDefaultProfile)
'End If

'#Select Outlook Profile 1=yes / 0=No
strPickLogonProfile = oWshShell.RegRead("HKCU\Software\Microsoft\Exchange\Client\Options\PickLogonProfile")

'#Ausgabe
'oWshShell.Popup "Username: " & strUsername & vbcrlf & _
'"Domain: " & strUserdomain & vbcrlf & _
'"Computername: " & strComputername & vbcrlf & _
'"OSCaption: " & strSystemCaption & vbcrlf & _
'"OSVersion: " & strSystemVersion & vbcrlf & _
'"Locale: " & strSystemLocale & vbcrlf & _
'"OSType: " & strOsType & vbcrlf & _
'"Select Outlook Profile: " & strPickLogonProfile & vbcrlf & _
'"Default Profile: " & strDefaultProfile , 2, "ListPST", 64

'#List Profiles and loop through them
Dim oProfiles, oProfile
oProfiles = GetOutlookProfiles

'#Script Ende
oWshShell.Popup "Outlook Profiles analyzed - thank you", 2, "ListPST", 64

Public Function GetOutlookProfiles()
'Sadly finds also deleted Profiles in the Registry :o(
'MSGBOX "Starting <GetOutlookProfiles>"

    Dim ProfileArray()
    Const HKEY_CURRENT_USER = &H80000001
    Const keypath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
    Dim strComputer,oReg,subKeys,ProfileName, pIterator, arrValue, SubFolders, objFolder, PSTPath, objFSO, objFile, strFileSize
    Const strPSTKey = "001f6700"

set objFSO = createobject("Scripting.FileSystemObject")

    strComputer = "."
    Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
    oReg.EnumKey HKEY_CURRENT_USER,keypath,subKeys
    'oReg.EnumKey HKEY_CURRENT_USER,keypath

    pIterator = 0
    For Each ProfileName In subKeys
        'MsgBox ("RegProfile: " & profileName )
        PSTPath = ""
        If instr(ProfileName, "EnterpriseVault") = 0 then
            oReg.EnumKey HKEY_CURRENT_USER,keypath & Profilename, subFolders
            For Each objFolder In subFolders
                oReg.GetBinaryValue HKEY_CURRENT_USER,keypath & Profilename & "\" & objFolder,strPSTKey,arrValue
                If Not IsNull(arrValue) Then
                    PSTPath = cstr(RegBintoString(arrValue))
                    set objFile = objFSO.GetFile(PSTPath)
                    strFilesize = objFile.Size
                    'oWshShell.Popup "Profile: " & profileName & " Size: " & strFilesize & " PST: " & PSTPath , 2, "ListPST", 64

                    '# LOG PST
                    strPSTFilepath = PSTPath
                    strProfilename = ProfileName
                    WriteToLog strUsername,strUserdomain,strComputername,strSystemCaption,strSystemVersion,strSystemLocale,strOsType,strPickLogonProfile,strDefaultProfile,strProfilename,strPSTFilepath,strFilesize

                    ReDim Preserve ProfileArray(pIterator+1)
                    ProfileArray(pIterator) = profileName
                    ProfileArray(pIterator) = PSTPath
                    pIterator = pIterator + 2
                End If
            next
        End If

        If PSTPath = "" then
            strPSTFilepath = "NO PST"
            strProfilename = ProfileName
            strFilesize = "0"
            WriteToLog strUsername,strUserdomain,strComputername,strSystemCaption,strSystemVersion,strSystemLocale,strOsType,strPickLogonProfile,strDefaultProfile,strProfilename,strPSTFilepath,strFilesize
        End if
    Next
    GetOutlookProfiles = ProfileArray
End Function

Public Function WriteToLog(byval strUsername,byval strUserdomain,byval strComputername,byval strSystemCaption,byval strSystemVersion, byval strSystemLocale, byval strOsType,byval strPickLogonProfile,byval strDefaultProfile,byval strProfilename,byval strPSTFilePath,byval strFilesize)
    'Msgbox "Writing something to log"
    Dim objFSO, objFile
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.OpenTextFile("C:\PST\" & strUsername & ".txt", 8, True)
    objFile.WriteLine(date & " " & time & ";" & strUsername & ";" & strUserdomain & ";" & strComputername & ";" & strSystemCaption & ";" & strSystemVersion & ";" & strSystemLocale & ";" & strOsType & ";" & strPickLogonProfile & ";" & strDefaultProfile & ";" & strProfilename & ";" & strPSTFilePath & ";" & strFilesize)
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
End Function

Public Function RegBintoString(arrValue)
DIM tmpText, i

    For i = 0 To UBound(arrValue) step 2
        tmpText = tmpText & Chr(arrValue(i))
    Next
    RegBintoString = tmpText
End Function

Grüsse

Andres Bohren