Adaptar script PST - Adicionar função GetSize

• Pergunta

• 

  

  0

  Entrar para Votar

  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

  Responder

  |

  Citação