Submitted By: Jonathan Man

Locates all the Microsoft Outlook .PST files for the logged-on user.

Visual Basic
Edit|Remove
Option Explicit

ChkScriptHost()

Dim ws, fso
Dim arrProfilesG(), NumProfiles, DefaultProfile, i

Set ws = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
DetectPST()
ChkNumProfiles()
For i = 0 To NumProfiles - 1
	ChkNumFolders(i)
Next
DispLine "Quiting Script..."
Set fso = Nothing
Set ws = Nothing

Sub ChkScriptHost()
	If InStr( Lcase(WScript.FullName), "wscript.exe") Then
		Dim ws
		Set ws = WScript.CreateObject("WScript.Shell")
		ws.Run("%ComSpec% /k cscript.exe //nologo """ & WScript.ScriptFullName & """")
		Set ws = Nothing
		WScript.Quit
	End If
End Sub


Sub DetectPST()
	Dim KeyPath, strComputer, FoldersKeyPath, objWMIReg, arrProfiles, i, j, k, l, NumProfiles, PSTFound
	Dim strValue, KeyValue, NumFolders, KeyName, PSTKeyName, PSTPath, PSTVersion, arrFolders(), FolderName, NumPST
	Const HKEY_CURRENT_USER = &H80000001
	strComputer = "."
	KeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
	
	On Error Resume Next
	DefaultProfile = ws.RegRead("HKCU\" & KeyPath & "DefaultProfile")
	Set objWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
	objWMIReg.EnumKey HKEY_CURRENT_USER, KeyPath, arrProfiles
	On Error GoTo 0
	NumProfiles = UBound(arrProfiles) + 1
	ReDim Preserve arrProfilesG(NumProfiles - 1, 2)
	For i = LBound(arrProfiles) To UBound(arrProfiles)
		FoldersKeyPath = "HKCU\" & KeyPath & arrProfiles(i) & "\9207f3e0a3b11019908b08002b2a56c2\01023d00"
		On Error Resume Next
		strValue = ws.RegRead(FoldersKeyPath)
		If Err = 0 Then
			For j = LBound(strValue) To UBound(strValue)
			    If strValue(j) < 16 Then
			    	KeyValue = KeyValue & "0" & LCase(CStr(Hex(strValue(j))))
			    Else
			    	KeyValue = KeyValue & LCase(CStr(Hex(strValue(j))))
			    End If
			Next
			NumFolders = (Len(KeyValue) / 32)
		End If
		On Error GoTo 0
		arrProfilesG(i, 0) = arrProfiles(i)
		NumPST = 0
		PSTFound = False
		For k = 1 To NumFolders
			FolderName = ""
			PSTPath = ""
			PSTVersion = ""
			KeyName = Mid(KeyValue, ((k - 1) * 32) + 1, 32)
			PSTKeyName = "HKCU\" & KeyPath & arrProfiles(i) & "\"& KeyName & "\001f6700"
			On Error Resume Next
			strValue = ws.RegRead(PSTKeyName)
			If Err = 0 Then
				For l = LBound(strValue) To UBound(strValue)
				    If strValue(l) <> 0 Then PSTPath = PSTPath & Chr(strValue(l))
				Next
				FolderName = ws.RegRead("HKCU\" & KeyPath & arrProfiles(i) & "\" & KeyName & "\001e3001")
				If Err = 0 Then
					PSTVersion = "97-2002"
					PSTFound = True
					NumPST = NumPST + 1
					ReDim Preserve arrFolders(2, NumPST - 1)
					arrFolders(0, NumPST - 1) = FolderName
					arrFolders(1, NumPST - 1) = PSTPath
					arrFolders(2, NumPST - 1) = PSTVersion
				Else
					strValue = ws.RegRead("HKCU\" & KeyPath & arrProfiles(i) & "\" & KeyName & "\001f3001")
					For l = LBound(strValue) To UBound(strValue)
						If strValue(l) <> 0 Then FolderName = FolderName & Chr(strValue(l))
					Next
					PSTVersion = "2003"
					PSTFound = True
					NumPST = NumPST + 1
					ReDim Preserve arrFolders(2, NumPST - 1)
					arrFolders(0, NumPST - 1) = FolderName
					arrFolders(1, NumPST - 1) = PSTPath
					arrFolders(2, NumPST - 1) = PSTVersion
				End If
			End If
			On Error GoTo 0
		Next
		arrProfilesG(i, 1) = PSTFound
		arrProfilesG(i, 2) = arrFolders
	Next
	Set objWMIReg = Nothing	
End Sub

Sub DispLine(Text)
	WScript.StdOut.WriteLine Text	
End Sub

Sub DispMsg(Text, Num, Keyword1, Keyword2)
	Select Case Num
		Case 0, 1
			DispLine Replace(Text, "&k", Keyword1)
		Case Else
			DispLine Replace(Text, "&k", Keyword2)
	End Select
End Sub

Sub ChkNumProfiles()
	NumProfiles = UBound(arrProfilesG, 1) + 1
	DispMsg "Found " & NumProfiles & " &k for this user.", NumProfiles, "profile", "profiles"
	DispLine "Default Profile: " & DefaultProfile
End Sub

Sub ChkNumFolders(i)
	Dim NumFolders, TotalNumFolders, j
	DispLine ""
	DispLine "Checking Profile: " & arrProfilesG(i,0)& " ..."
	If arrProfilesG(i, 1) = True Then
		TotalNumFolders = UBound(arrProfilesG(i, 2), 2) + 1
		For j = 0 To TotalNumFolders - 1
			If arrProfilesG(i, 2)(2, j) = "97-2002" Then
				NumFolders = NumFolders + 1
			End If
		Next
		DispMsg vbTab & "Found totally " & TotalNumFolders & " personal &k under profile " & arrProfilesG(i, 0) & ".", NumFolders, "folder", "folders"
		DispLine ""
		DispPSTInfo(arrProfilesG(i, 2))
		If NumFolders > 0 Then
			DispMsg vbTab & "Found " & NumFolders & " &k old version.", NumFolders, "is", "are"
		Else
			DispLine vbTab & "No old version personal folder found."
		End If
	Else
		DispLine vbTab & "No persional folder found."
	End If
End Sub

Sub DispPSTInfo(arrFolders)
	Dim i
	For i = LBound(arrFolders, 2) To UBound(arrFolders, 2) 
		DispLine vbTab & "Folder Name: " & arrFolders(0, i)
		DispLine vbTab & "Path: " & arrFolders(1, i)
		DispLine vbTab & "Format: " & arrFolders(2, i)
		DispLine vbTab & "Size: " & FormatNumber(fso.GetFile(arrFolders(1, i)).Size,0,,-1) & " Bytes"
		DispLine ""
	Next
End Sub