0

I have found some code on the Internet for listing out Outlook Profile Info and I would like to it, but it gives the error: Type mismatch:'[string: "A"]', at line 74 (code 800A000D). I don't know why it's not working.

Here is the code:

    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))
 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 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 
 Else
 If Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then IsUsableArray = -1 
 End If
 End Function

1 Answer 1

1

The script works on my system if i correct the extra space at line 8 (Windows Messaging Subsystem) It is a big script for what it offers, see here for a smaller one which offers more using the free to download library Redemption at http://www.dimastr.com/redemption/home.htm which is what CDO should have been.

set Session = CreateObject("Redemption.RDOSession")
const skUnknown = 0, olStoreANSI = 1, olStoreUnicode = 2, skPrimaryExchangeMailbox = 3, skPublicFolders = 5, skDelegateExchangeMailbox = 4

Session.Logon
for each Store in Session.Stores
  if (Store.StoreKind = olStoreANSI) then
    wscript.echo Store.Name & " - " & Store.PstPath & " " & Store.Name
  elseif (Store.StoreKind = olStoreUnicode) Then
    wscript.echo Store.Name & " - " & Store.PstPath
  ElseIf (Store.StoreKind = skPrimaryExchangeMailbox) or (Store.StoreKind = skDelegateExchangeMailbox) or (Store.StoreKind = skPublicFolders) Then
    wscript.echo Store.Name & " - " & Store.ServerDN
  Else 
    wscript.echo Store.Name & " - "  & Store.StoreKind
  End If
next

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.