Question

我正在尝试编写一个脚本来检查Outlook配置文件并找到它们的相关pst并将其写入txt。我们有一些用户必须拥有2个单独的配置文件，并且必须在单独的网络共享上存储一些pst。我确实找到了可以很棒的脚本，但只列出了DefaultProfile。我想知道是否有人知道在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 
 '_________________________________________________________________________________________________________

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

Answer 2

对于Outlook 2013，注册表项已更改。您将能够在

中找到个人资料

HKCU \软件\微软\办公室\ 15.0 \ Outlook中\配置文件

C＃.NET

identStyle :: TokenParsing m => IdentifierStyle m
identStyle = T.emptyIdents { _styleStart = letter } { _styleLetter = letter }

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

2 个答案: