Использование VBScript Список всех профилей Outlook и PST

Я пытаюсь написать сценарий для проверки профилей 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 
 '_________________________________________________________________________________________________________

outlook vbscript pst
person Joe Williams    schedule 07.11.2011    source источник

Ответы (2)


arrow_upward
3
arrow_downward

Сценарий, который вы указали в своем вопросе, содержит функцию с именем 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
person Paul-Jan    schedule 07.11.2011

arrow_upward
1
arrow_downward

Для 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()
person Michel    schedule 27.01.2016