インターネットでOutlookプロファイル情報を一覧表示するためのコードを見つけました。それを実行したいのですが、次のエラーが表示されます。タイプの不一致：'[文字列： "A"]'、行74（コード800A000D）。なぜ機能しないのかわかりません。
コードは次のとおりです。
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