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

Question

我正在尝试编写一个脚本来检查Outlook配置文件并查找它们相关的pst文件，并将其写入txt文件。我们有一些用户必须拥有两个单独的配置文件，并且必须在单独的网络共享上存储某些pst文件。我找到了一个非常好用的脚本，但它只列出了默认配置文件。我想知道是否有人知道用vbscript实现这个功能的方法。对于任何搜索此处的人，下面是默认配置文件的脚本。

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 
 '_________________________________________________________________________________________________________ 

- Joe Williams

Answer 1

您在问题中提供的脚本包含一个名为 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

- Paul-Jan

Answer 2

对于Outlook 2013，注册表键已更改。 您将能够在其中找到配置文件

HKCU\Software\Microsoft\Office\15.0\Outlook\Profiles

c#.net

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

- Michel