none
Adaptar script PST - Adicionar função GetSize RRS feed

  • Pergunta

  • Encontrei o script abaixo que esta funcionando, porém, adicionei a função de obter o tamanho do arquivo PST e não consigo concatenar o caminho do pst com o tamanho dele.

    Nas tentativas que fiz para exibir o tamanho do PST via wscript.echo GetSize(PSTFileName(r_ProfilesRoot)) ocorre erro na linha 123, primeiro caractere, onde informa que o tipo é incompatível (lBound).

    Se eu comento a última linha do script a saida do log fica assim:

    Default Profile: Outlook

    === Profile: Outlook ===
    Nome no Outlook: Relatorios 
       => Nome e local do PST: C:\Users\joao\Documents\Arquivos do Outlook\Relatorios.pst 
    Nome no Outlook: Maria_2012 
       => Nome e local do PST: P:\Outlook\Maria_2012.pst 

    Segue código do script no qual adicionei as funções GetSize(zFile) e ConvertSize:


    Option Explicit 
    'On Error Resume Next 
    Const HKEY_CURRENT_USER = &H80000001 
    const HKEY_LOCAL_MACHINE = &H80000002 
    const KEY_QUERY_VALUE = &H0001 
    Const r_PSTGuidLocation = "01023d00" 
    Const r_MasterConfig = "01023d0e" 
    Const r_PSTCheckFile = "00033009" 
    Const r_PSTFile = "001f6700" 
    Const r_PSTNameFile = "001f3001" 
    Const r_PSTNameFileA = "001f3006" 
    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, OProfile, errchk, ProfilName, zi 
    
    
    oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName 
    
    objPSTLog.WriteLine("Default Profile: "+DefaultProfileName) 
    objPSTLog.WriteLine("") 
    objPSTLog.WriteLine("") 
    
    errchk = oReg.EnumKey (HKEY_CURRENT_USER,r_DefaultOutlookProfile,OProfile) 
    IF errchk=0 THEN 
    For zi = lBound(OProfile) to uBound(OProfile)    
    ProfilName=OProfile(zi) 
    objPSTLog.WriteLine("=== Profile: "+ProfilName+" ===") 
    GetPSTsForProfile(ProfilName) 
    objPSTLog.WriteLine("") 
    objPSTLog.WriteLine("") 
    Next    
    END IF 
    
    
    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 
    If IsUsableArray (P_PSTGuildValue) Then
     For Each x in P_PSTGuildValue 
     P_PSTCheck = P_PSTCheck + Hex(x)
    Next
    End If
        
    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, P_PST1, ChkAccess, errcheck 
    Dim strString:strString = "Nome no Outlook: " 
    
    errcheck = oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFile,P_PST1) 
    IF errcheck=0 THEN 
    z = lBound(P_PST1) 
    While z <=uBound(P_PST1)-1 
    strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1)) 
    z=z+2 
    Wend 
    ELSE 
    errcheck=oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFileA,P_PST1) 
    IF errcheck=0 THEN 
    z = lBound(P_PST1) 
    While z <=uBound(P_PST1)-1 
    strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1)) 
    z=z+2 
    Wend 
    END IF 
    END IF 
    strString = strString + chr (13)+chr(10)+"   => Nome e local do PST: " 
    oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName 
    z = lBound(P_PSTName) 
    While z <=uBound(P_PSTName)-1 
    strString = strString & ChrW(P_PSTName(z)+256*P_PSTName(z+1)) 
    z=z+2 
    Wend    
    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 
    '_________________________________________________________________________________________________________ 
    
    Function IsUsableArray(rvnt)
    '-- Use this function to test for a Null, Empty or an undimensioned array.
    '-- Useful b/c some interfaces can hold properties for which if they have a
    '-- value will be an Array but may also be Null or an undimensioned Array.
    '-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. 
    '-- It returns -1 if it is passed a string, long, etc...
    '-- It returns 0 for an empty array or the number of elements in the first dimension.
    
    IsUsableArray = 0 
    
    If (VarType(rvnt) And 8192) = 8192 Then 
     IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1 
     ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then 
     IsUsableArray = -1 
    End If
    
    End Function
    
    '_____________________________________________________________________________________________________________________________
    '_____________________________________________________________________________________________________________________________
    
    
    Function GetSize(zFile)
    Dim objFSO      :Set objFSO = CreateObject("Scripting.FileSystemObject")
    dim objFile     :Set objFile = objFSO.GetFile(zFile)
    
    GetSize = ConvertSize(objFile.Size)
    
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function ConvertSize(Size)
    
    Do While InStr(Size,",") 
    'Remove commas from size     
     CommaLocate = InStr(Size,",")     
     Size = Mid(Size,1,CommaLocate - 1) & _         
     Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate) 
    Loop
    
    Dim Suffix:Suffix = " Bytes" 
    If Size >= 1024 Then suffix = " KB" 
    If Size >= 1048576 Then suffix = " MB" 
    If Size >= 1073741824 Then suffix = " GB" 
    If Size >= 1099511627776 Then suffix = " TB"
    
    Select Case Suffix
     Case " KB" Size = Round(Size / 1024, 1)
     Case " MB" Size = Round(Size / 1048576, 1)
     Case " GB" Size = Round(Size / 1073741824, 1)
     Case " TB" Size = Round(Size / 1099511627776, 1) 
    End Select
    
    ConvertSize = Size & Suffix 
    
    End Function 
    
    'wscript.echo GetSize(PSTFileName(r_ProfilesRoot))

    .

    .

    Esse é o script original que contém as duas funções que citei acima mas ele não é tão completo:

    .

    .

     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  
    
    oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue 
    
    If IsUsableArray (strValue) Then
     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 PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _ 
     PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
     wscript.echo GetSize(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _ 
     PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))) 
     End If
     
     strPSTGuid = "" 
     
     End If            
     Next 
    End If
    
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function GetSize(zFile)
    Dim objFSO      :Set objFSO = CreateObject("Scripting.FileSystemObject")
    dim objFile     :Set objFile = objFSO.GetFile(zFile)
    
    GetSize = ConvertSize(objFile.Size)
    
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function ConvertSize(Size)
    
    Do While InStr(Size,",") 
    'Remove commas from size     
     CommaLocate = InStr(Size,",")     
     Size = Mid(Size,1,CommaLocate - 1) & _         
     Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate) 
    Loop
    
    Dim Suffix:Suffix = " Bytes" 
    If Size >= 1024 Then suffix = " KB" 
    If Size >= 1048576 Then suffix = " MB" 
    If Size >= 1073741824 Then suffix = " GB" 
    If Size >= 1099511627776 Then suffix = " TB"
    
    Select Case Suffix
     Case " KB" Size = Round(Size / 1024, 1)
     Case " MB" Size = Round(Size / 1048576, 1)
     Case " GB" Size = Round(Size / 1073741824, 1)
     Case " TB" Size = Round(Size / 1099511627776, 1) 
    End Select
    
    ConvertSize = Size & Suffix 
    
    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
    
    If IsUsableArray (P_PSTGuildValue) Then
     For Each x in P_PSTGuildValue 
     P_PSTCheck = P_PSTCheck + Hex(x)
     Next
    End If
    
    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 
    
    If IsUsableArray (P_PSTGuildValue) Then 
     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 If
    
    End Function  
    '_____________________________________________________________________________________________________________________________
    
    Function PSTFileName(p_PSTGuid) 
    Dim z, P_PSTName 
    Dim strString : strString = "" 
    
    oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
    
    If IsUsableArray (P_PSTName) Then
     For Each z in P_PSTName
     If z > 0 Then strString = strString & Chr(z)
     Next
    End If
    
    PSTFileName = strString
    
    End Function  
    '_________________________________________________________________________________________________________ 
    Function ExpandEvnVariable(ExpandThis)
    Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
    
    ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
    
    End Function         
    '_________________________________________________________________________________________________________ 
    
    Function IsUsableArray(rvnt)
    '-- Use this function to test for a Null, Empty or an undimensioned array.
    '-- Useful b/c some interfaces can hold properties for which if they have a
    '-- value will be an Array but may also be Null or an undimensioned Array.
    '-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. 
    '-- It returns -1 if it is passed a string, long, etc...
    '-- It returns 0 for an empty array or the number of elements in the first dimension.
    
    IsUsableArray = 0 
    
    If (VarType(rvnt) And 8192) = 8192 Then 
     IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1 
     ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then 
     IsUsableArray = -1 
    End If
    
    End Function 



    • Editado K.ryn quarta-feira, 24 de setembro de 2014 10:21
    quarta-feira, 24 de setembro de 2014 10:16

Respostas

  • olá K.ryn,

    Fiz uma alteração no script, esses ocorrem devido alteração que você fez na função "PSTFileName(p_PSTGuid)", no Script original ele funciona devido o retorno ser o caminho correto da PST, quando você alterou mundou o retorno da função...

    o que fiz foi simplesmente colocar a função original, onde o retorno é dado somente com o caminho do arquivo...

    faça os testes e veja se funciona adequadamente...

    Option Explicit
    'On Error Resume Next
    Const HKEY_CURRENT_USER = &H80000001
    const HKEY_LOCAL_MACHINE = &H80000002
    const KEY_QUERY_VALUE = &H0001
    Const r_PSTGuidLocation = "01023d00"
    Const r_MasterConfig = "01023d0e"
    Const r_PSTCheckFile = "00033009"
    Const r_PSTFile = "001f6700"
    Const r_PSTNameFile = "001f3001"
    Const r_PSTNameFileA = "001f3006"
    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, OProfile, errchk, ProfilName, zi
    
    oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName
    objPSTLog.WriteLine("Default Profile: " + DefaultProfileName)
    objPSTLog.WriteLine("")
    errchk = oReg.EnumKey (HKEY_CURRENT_USER,r_DefaultOutlookProfile,OProfile)
    	IF errchk=0 THEN
    		For zi = lBound(OProfile) to uBound(OProfile)
    			ProfilName=OProfile(zi)
    			objPSTLog.WriteLine("=== Profile: " + ProfilName + " ===")
    			GetPSTsForProfile(ProfilName)
    			objPSTLog.WriteLine("")
    		Next
    	END IF
    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.Write(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)))
    				objPSTLog.WriteLine "[Tamanho: " & GetSize(PSTFileNames(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
    	If IsUsableArray (P_PSTGuildValue) Then
    		For Each x in P_PSTGuildValue
    			P_PSTCheck = P_PSTCheck + Hex(x)
    		Next
    	End If
    	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, P_PST1, ChkAccess, errcheck
    	Dim strString:strString = "Nome no Outlook: "
    	errcheck = oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFile,P_PST1)
    
    	IF errcheck = 0 THEN
    		z = lBound(P_PST1)
    		While z <=uBound(P_PST1)-1
    			strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
    			z=z+2
    		Wend
    	ELSE
    		errcheck=oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFileA,P_PST1)
    		IF errcheck=0 THEN
    			z = lBound(P_PST1)
    			While z <=uBound(P_PST1)-1
    				strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
    				z=z+2
    			Wend
    		END IF
    	END IF
    	strString = strString + chr (13)+chr(10)+"   => Nome e local do PST: "
    	oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
    	z = lBound(P_PSTName)
    	While z <=uBound(P_PSTName)-1
    		strString = strString & ChrW(P_PSTName(z)+256*P_PSTName(z+1))
    		z=z+2
    	Wend
    	PSTFileName = strString
    	Set z = nothing
    	Set P_PSTName = nothing
    End Function
    
    'Função para efetuar o tamanho da pst_______________________________________________________________________
    Function PSTFileNames(p_PSTGuid)
    	Dim P_PSTNames, P_PSTName,z,strString
    	P_PSTNames = P_PSTName
    	oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTNames
    
    	If IsUsableArray (P_PSTNames) Then
    		For Each z in P_PSTNames
    			If z > 0 Then strString = strString & Chr(z)
    		Next
    	End If
    	PSTFileNames = strString
    End Function
    '_________________________________________________________________________________________________________
    Function ExpandEvnVariable(ExpandThis)
    	Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
    	ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
    End Function
    '_________________________________________________________________________________________________________
    
    Function IsUsableArray(rvnt)
    '-- Use this function to test for a Null, Empty or an undimensioned array.
    '-- Useful b/c some interfaces can hold properties for which if they have a
    '-- value will be an Array but may also be Null or an undimensioned Array.
    '-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned.
    '-- It returns -1 if it is passed a string, long, etc...
    '-- It returns 0 for an empty array or the number of elements in the first dimension.
    
    	IsUsableArray = 0
    
    	If (VarType(rvnt) And 8192) = 8192 Then
    		IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1
    	ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then
    		IsUsableArray = -1
    	End If
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function GetSize(zFile)
    	Dim objFSO      :Set objFSO = CreateObject("Scripting.FileSystemObject")
    	dim objFile     :Set objFile = objFSO.GetFile(zFile)
    	GetSize = ConvertSize(objFile.Size)
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function ConvertSize(Size)
    	Dim Suffix:Suffix = " Bytes"
    	Do While InStr(Size,",")
    		'Remove commas from size
    		CommaLocate = InStr(Size,",")
    		Size = Mid(Size,1,CommaLocate - 1) & _
    		Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
    	Loop
    
    	If Size >= 1024 Then suffix = " KB"
    	If Size >= 1048576 Then suffix = " MB"
    	If Size >= 1073741824 Then suffix = " GB"
    	If Size >= 1099511627776 Then suffix = " TB"
    	Select Case Suffix
    		Case " KB" Size = Round(Size / 1024, 1)
    		Case " MB" Size = Round(Size / 1048576, 1)
    		Case " GB" Size = Round(Size / 1073741824, 1)
    		Case " TB" Size = Round(Size / 1099511627776, 1)
    	End Select
    
    	ConvertSize = Size & Suffix
    End Function
    
    


    att, Aparecido Deveza

    • Sugerido como Resposta Fábio JrModerator domingo, 19 de outubro de 2014 14:36
    • Marcado como Resposta K.ryn terça-feira, 21 de outubro de 2014 10:11
    domingo, 19 de outubro de 2014 03:21

Todas as Respostas

  • Alguém?

    Obrigado

    quarta-feira, 1 de outubro de 2014 12:07
  • Ninguém... nem uma dica? Já montei e desmontei algumas vezes mas sempre dá algum erro. Preciso apenas adicionar a função getsize e incluí-la no log exportado.
    segunda-feira, 6 de outubro de 2014 19:00
  • olá K.ryn,

    Fiz uma alteração no script, esses ocorrem devido alteração que você fez na função "PSTFileName(p_PSTGuid)", no Script original ele funciona devido o retorno ser o caminho correto da PST, quando você alterou mundou o retorno da função...

    o que fiz foi simplesmente colocar a função original, onde o retorno é dado somente com o caminho do arquivo...

    faça os testes e veja se funciona adequadamente...

    Option Explicit
    'On Error Resume Next
    Const HKEY_CURRENT_USER = &H80000001
    const HKEY_LOCAL_MACHINE = &H80000002
    const KEY_QUERY_VALUE = &H0001
    Const r_PSTGuidLocation = "01023d00"
    Const r_MasterConfig = "01023d0e"
    Const r_PSTCheckFile = "00033009"
    Const r_PSTFile = "001f6700"
    Const r_PSTNameFile = "001f3001"
    Const r_PSTNameFileA = "001f3006"
    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, OProfile, errchk, ProfilName, zi
    
    oReg.GetStringValue HKEY_CURRENT_USER,r_DefaultOutlookProfile,r_DefaultProfileString,DefaultProfileName
    objPSTLog.WriteLine("Default Profile: " + DefaultProfileName)
    objPSTLog.WriteLine("")
    errchk = oReg.EnumKey (HKEY_CURRENT_USER,r_DefaultOutlookProfile,OProfile)
    	IF errchk=0 THEN
    		For zi = lBound(OProfile) to uBound(OProfile)
    			ProfilName=OProfile(zi)
    			objPSTLog.WriteLine("=== Profile: " + ProfilName + " ===")
    			GetPSTsForProfile(ProfilName)
    			objPSTLog.WriteLine("")
    		Next
    	END IF
    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.Write(PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)))
    				objPSTLog.WriteLine "[Tamanho: " & GetSize(PSTFileNames(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
    	If IsUsableArray (P_PSTGuildValue) Then
    		For Each x in P_PSTGuildValue
    			P_PSTCheck = P_PSTCheck + Hex(x)
    		Next
    	End If
    	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, P_PST1, ChkAccess, errcheck
    	Dim strString:strString = "Nome no Outlook: "
    	errcheck = oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFile,P_PST1)
    
    	IF errcheck = 0 THEN
    		z = lBound(P_PST1)
    		While z <=uBound(P_PST1)-1
    			strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
    			z=z+2
    		Wend
    	ELSE
    		errcheck=oReg.GetBinaryValue (HKEY_CURRENT_USER,p_PSTGuid,r_PSTNameFileA,P_PST1)
    		IF errcheck=0 THEN
    			z = lBound(P_PST1)
    			While z <=uBound(P_PST1)-1
    				strString = strString & ChrW(P_PST1(z)+256*P_PST1(z+1))
    				z=z+2
    			Wend
    		END IF
    	END IF
    	strString = strString + chr (13)+chr(10)+"   => Nome e local do PST: "
    	oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
    	z = lBound(P_PSTName)
    	While z <=uBound(P_PSTName)-1
    		strString = strString & ChrW(P_PSTName(z)+256*P_PSTName(z+1))
    		z=z+2
    	Wend
    	PSTFileName = strString
    	Set z = nothing
    	Set P_PSTName = nothing
    End Function
    
    'Função para efetuar o tamanho da pst_______________________________________________________________________
    Function PSTFileNames(p_PSTGuid)
    	Dim P_PSTNames, P_PSTName,z,strString
    	P_PSTNames = P_PSTName
    	oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTNames
    
    	If IsUsableArray (P_PSTNames) Then
    		For Each z in P_PSTNames
    			If z > 0 Then strString = strString & Chr(z)
    		Next
    	End If
    	PSTFileNames = strString
    End Function
    '_________________________________________________________________________________________________________
    Function ExpandEvnVariable(ExpandThis)
    	Dim objWSHShell    :Set objWSHShell = CreateObject("WScript.Shell")
    	ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
    End Function
    '_________________________________________________________________________________________________________
    
    Function IsUsableArray(rvnt)
    '-- Use this function to test for a Null, Empty or an undimensioned array.
    '-- Useful b/c some interfaces can hold properties for which if they have a
    '-- value will be an Array but may also be Null or an undimensioned Array.
    '-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned.
    '-- It returns -1 if it is passed a string, long, etc...
    '-- It returns 0 for an empty array or the number of elements in the first dimension.
    
    	IsUsableArray = 0
    
    	If (VarType(rvnt) And 8192) = 8192 Then
    		IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1
    	ElseIf Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then
    		IsUsableArray = -1
    	End If
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function GetSize(zFile)
    	Dim objFSO      :Set objFSO = CreateObject("Scripting.FileSystemObject")
    	dim objFile     :Set objFile = objFSO.GetFile(zFile)
    	GetSize = ConvertSize(objFile.Size)
    End Function
    '_____________________________________________________________________________________________________________________________
    
    Function ConvertSize(Size)
    	Dim Suffix:Suffix = " Bytes"
    	Do While InStr(Size,",")
    		'Remove commas from size
    		CommaLocate = InStr(Size,",")
    		Size = Mid(Size,1,CommaLocate - 1) & _
    		Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
    	Loop
    
    	If Size >= 1024 Then suffix = " KB"
    	If Size >= 1048576 Then suffix = " MB"
    	If Size >= 1073741824 Then suffix = " GB"
    	If Size >= 1099511627776 Then suffix = " TB"
    	Select Case Suffix
    		Case " KB" Size = Round(Size / 1024, 1)
    		Case " MB" Size = Round(Size / 1048576, 1)
    		Case " GB" Size = Round(Size / 1073741824, 1)
    		Case " TB" Size = Round(Size / 1099511627776, 1)
    	End Select
    
    	ConvertSize = Size & Suffix
    End Function
    
    


    att, Aparecido Deveza

    • Sugerido como Resposta Fábio JrModerator domingo, 19 de outubro de 2014 14:36
    • Marcado como Resposta K.ryn terça-feira, 21 de outubro de 2014 10:11
    domingo, 19 de outubro de 2014 03:21
  • Funcionou!!!! Muito obrigado.
    terça-feira, 21 de outubro de 2014 10:11