Psts auslesen und in .txt-datei speichern

net use >C:\pstPfade\netz.txt
reg query "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Devices" >> C:\drucker.txt  
\\server1\cscript \\server1\software$\pstPfade.vbs >C:\PST-Export.txt

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