Citation :
Option Explicit
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_DefaultProfileString = "DefaultProfile"
Dim oReg :Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv" )
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
GetPSTsForProfile(DefaultProfileName)
'_____________________________________________________________________________________________________________________________
Function GetPSTsForProfile(p_profileName)
Dim strHexNumber, strPSTGuid, strFoundPST
Dim fso
Dim Source
Dim Destination
Dim oNetwork
Dim sUserName
Dim sComputerName
Dim strDirectory
Dim strUNC
Dim ObjFolder
'Variables pour lancement automatique d'Outlook
Dim oShell
Set oShell = WScript.CreateObject ("WScript.Shell" ) WScript.Echo "Attention, Outlook va être fermé. Merci de sauvegarder vos travaux puis cliquez sur OK pour continuer."
'Variables pour arrêt du processus "OUTLOOK.EXE"
Dim objWMIService, objProcess, colProcess
Dim strComputer, strProcessKill, objWMI, sQuery
strComputer = "."
strProcessKill = "'OUTLOOK.EXE'" Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2" ) Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = " & strProcessKill )
For Each objProcess in colProcess
objProcess.Terminate()
Next Set fso = CreateObject("Scripting.FileSystemObject" )
Set oNetwork = CreateObject("Wscript.network" )
sUserName = oNetwork.UserName
sComputerName = oNetwork.ComputerName
strUNC = "\\serveur\share"
strDirectory = strUNC & "\" & sUserName & "_" & sComputerName
Wscript.Echo "Nom du répertoire généré : " & strDirectory Wscript.Echo "Veuillez patienter... Merci de ne pas ouvrir Outlook jusqu'au prochain message" Set objFolder = fso.CreateFolder(strDirectory) oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
For Each i In strValue
If Len(Hex(i)) = 1 Then
strHexNumber = CInt("0" ) & Hex(i)
Else
strHexNumber = Hex(i)
End If
strPSTGuid = strPSTGuid + strHexNumber
If Len(strPSTGuid) = 32 Then
If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
Wscript.Echo "Fichier(s) .pst trouvé(s) : " & PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
Source = PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
Destination = strDirectory & "\"
fso.CopyFile Source, Destination,TRUE End If
strPSTGuid = ""
End If
Next Wscript.Echo "La procédure est terminée, Outlook va se relancer" 'Lancement processus "OUTLOOK.EXE"
oShell.Run "outlook"
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 Each x in P_PSTGuildValue
P_PSTCheck = P_PSTCheck + Hex(x)
Next
If P_PSTCheck=20 Then
IsAPST=True
End If
End Function
'_____________________________________________________________________________________________________________________________
Function PSTlocation(p_PSTGuid)
Dim y, P_PSTGuildValue
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
For Each y In P_PSTGuildValue
If Len(Hex(y)) = 1 Then
PSTlocation = PSTlocation & CInt("0" ) & Hex(y)
Else
PSTlocation = PSTlocation & Hex(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 Each z in P_PSTName
If z > 0 Then strString = strString & Chr(z)
Next
PSTFileName = strString
End Function
'_________________________________________________________________________________________________________
Function ExpandEvnVariable(ExpandThis)
Dim objWSHShell :Set objWSHShell = CreateObject("WScript.Shell" )
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%" )
End Function
'_________________________________________________________________________________________________________
| 
