使用VBScript列出所有Outlook配置文件和PST的

我正在嘗試編寫腳本來檢查Outlook配置文件，並找到它們的relavent pst並將其寫入到txt。我們有一些用戶必須擁有2個獨立的配置文件，並且必須在一個單獨的網絡共享中存儲一些pst。我確實找到了可以很好地工作的腳本，但只列出了DefaultProfile。我想知道是否有人知道在VBScript中這樣做的方法。對於任何人在這裏搜索是默認配置文件的腳本。使用VBScript列出所有Outlook配置文件和PST的

Option Explicit 
'On Error Resume Next 
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_DefaultOutlookProfile = "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 objFSO :Set objFSO = CreateObject("Scripting.FileSystemObject") 
Dim objPSTLog :Set objPSTLog = objFSO.OpenTextFile(ExpandEvnVariable("Temp") & "\pst.log",2,True)  
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName 


oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName 

objPSTLog.WriteLine(DefaultProfileName) 
GetPSTsForProfile(DefaultProfileName) 


objPSTLog.close 
Set objPSTLog = Nothing  
'_____________________________________________________________________________________________________________________________ 
Function GetPSTsForProfile(p_profileName) 
Dim strHexNumber, strPSTGuid, strFoundPST 
Dim HexCount :HexCount = 0 

oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue 
    For i = lBound(strValue) to uBound(strValue)  
      If Len(Hex(strValue(i))) = 1 Then 
       strHexNumber = "0" & Hex(strValue(i)) 
      Else 
       strHexNumber = Hex(strValue(i)) 
      End If   
     strPSTGuid = strPSTGuid + strHexNumber 
     HexCount = HexCount + 1 
      If HexCount = 16 Then 
        If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then 
         'wscript.echo vbCrLf & "PST FOUND: " & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) 
         'strFoundPST = strFoundPST & "??" & PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)) 
         objPSTLog.WriteLine(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))) 
        End If  
       HexCount = 0 
       strPSTGuid = "" 
      End If    
    Next 
    'GetPSTsForProfile = strFoundPST 
End Function 
'_____________________________________________________________________________________________________________________________ 
Function IsAPST(p_PSTGuid) 
Dim x, P_PSTGuildValue 
Dim P_PSTCheck:P_PSTCheck=0 
IsAPST=False 
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue 
    For x = lBound(P_PSTGuildValue) to uBound(P_PSTGuildValue)  
     P_PSTCheck = P_PSTCheck + Hex(P_PSTGuildValue(x)) 
    Next  
    If P_PSTCheck=20 Then 
     IsAPST=True 
    End If  
End Function 
'_____________________________________________________________________________________________________________________________ 
Function PSTlocation(p_PSTGuid) 
Dim y, P_PSTGuildValue, t_strHexNumber 
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue 
    For y = lBound(P_PSTGuildValue) to uBound(P_PSTGuildValue)  
     If Len(Hex(P_PSTGuildValue(y))) = 1 Then 
      PSTlocation = PSTlocation + "0" & Hex(P_PSTGuildValue(y)) 
     Else 
      PSTlocation = PSTlocation + Hex(P_PSTGuildValue(y))  
     End If  
    Next  
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 z = lBound(P_PSTName) to uBound(P_PSTName)  
     If P_PSTName(z) > 0 Then 
      strString = strString & Chr(P_PSTName(z)) 
     End If  
    Next  
    PSTFileName = strString 
Set z = nothing 
Set P_PSTName = nothing 
End Function 
'_________________________________________________________________________________________________________ 
Function ExpandEvnVariable(ExpandThis) 
Dim objWSHShell :Set objWSHShell = CreateObject("WScript.Shell") 
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%") 
End Function 
'_________________________________________________________________________________________________________

來源

2011-11-07 Joe Williams

你在你的問題中提供的腳本包含一個名爲GetPSTsForProfile功能，這需要一個配置文件名稱，然後做它的魔力得到PST信息。所以你已經有了這個難題的一部分。

現在您只需要列舉所有配置文件。配置文件以HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles內的子項存儲。

使用從你上面貼的腳本的條款和變量，這裏是如何做到的枚舉：

Const HKEY_CURRENT_USER = &H80000001 
Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles" 

strComputer = "." 

Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _ 
    strComputer & "\root\default:StdRegProv") 

oReg.EnumKey HKEY_CURRENT_USER,r_ProfilesRoot,subKeys 

For Each profileName In subKeys 
    objPSTLog.WriteLine(profileName) 
    GetPSTsForProfile(profileName) 
Next

來源

2011-11-07 20:09:51

保羅 - 揚：非常完美的感謝。 –

對於Outlook 2013，該註冊表項的變化。您將能夠找到配置文件中

HKCU \軟件\微軟\辦公室\ 15.0 \ Outlook中\ Profiles文件

C＃.NET

string profilesRoot = "Software\\Microsoft\\Office\\15.0\\Outlook\\Profiles"; 
Registry.CurrentUser.OpenSubKey(profilesRoot).GetSubKeyNames()

來源

2016-01-27 12:23:27 Michel

使用VBScript列出所有Outlook配置文件和PST的

回答

相關問題