Текущее время: 24 ноя 2017, 20:32




Начать новую тему Ответить на тему  [ 1 сообщение ] 
Местонахождение PST-файлов (с поддержкой русских путей) 
Автор Сообщение
Администратор
Аватар пользователя

Зарегистрирован: 16 мар 2010, 10:23
Сообщений: 124
Сообщение Местонахождение 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: " & 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
         if P_PSTName(z+1)=4 then
            strString = strString & Chr((176)+P_PSTName(z))
         else
            if P_PSTName(z)<>4 then strString = strString & Chr(P_PSTName(z))
         end if
         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
'_______________

_________________
...
– Отнеси его Сисадмину, – сказал Инь Фу Во. – Мне кактус не поможет.
– Почему? – обиженно спросила Ли Чан.
– Для него нет драйвера под FreeBSD, – ответил Учитель.


02 июн 2010, 09:55
Профиль ICQ WWW
Показать сообщения за:  Сортировать по:  
Начать новую тему Ответить на тему  [ 1 сообщение ] 


Кто сейчас на форуме

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
cron
Powered by phpBB © phpBB Group. Русская поддержка phpBB