Declare PtrSafe Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As LongPtr) As Long
Declare PtrSafe Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare PtrSafe Function RegQueryValueExstr Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare PtrSafe Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare PtrSafe Function RegQueryValueExDbl Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Double, lpcbData As Long) As Long
Declare PtrSafe Function RegQueryValueExBin Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Declare PtrSafe Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Function saGetRegValue2(SubKey, DName, vValue, Optional RootKey) As Integer
'********************************************************
'*** レジストリ値の取得
'*** 全レジストリタイプ対応
'***
'*** RtnCD -1 : DataType Error
'*** 2 : RegKey not found
'*** -2 : Byte Table too short (Binary)
'*** oth : Registry Open Error
'***
'*** レジストリのタイプによって受け取りのデータ型を変更のこと
'*** REG_SZ -------- String
'*** REG_MULTI_SZ -- String
'*** REG_Expand_SZ - String
'*** REG_DWORD ----- Long
'*** REG_QWORD(64) - String, Double, Byte
'*** REG_BINARY ---- Byte
'********************************************************
Dim phkResult As Long
Dim cch As Long
Dim Ret, RK
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim dValue As Double
Dim sValue As String
Dim bValue(7) As Byte
If IsMissing(RootKey) Then
RK = &H80000001 'HKEY_CURRENT_USER
Else
Select Case RootKey
Case "HKCR", "HKEY_CLASSES_ROOT": RK = &H80000000
Case "HKCU", "HKEY_CURRENT_USER": RK = &H80000001
Case "HKCC", "HKEY_CURRENT_CONFIG": RK = &H80000005
Case "HKDD", "HKEY_DYN_DATA": RK = &H80000006
Case "HKLM", "HKEY_LOCAL_MACHINE": RK = &H80000002
Case "HKU", "HKEY_USERS": RK = &H80000003
End Select
End If
Ret = RegOpenKeyEx(RK, SubKey, 0, 1, phkResult)
If Ret <> 0 Then
saGetRegValue2 = Ret
Exit Function
End If
On Error GoTo QueryValueExError
lrc = RegQueryValueExNULL(phkResult, DName, 0&, lType, 0&, cch)
If lrc <> 0 Then Error 5
Select Case lType
Case 1 ' REG_SZ
sValue = String(cch, 0)
lrc = RegQueryValueExstr(phkResult, DName, 0&, lType, sValue, cch)
If lrc = 0 Then
vValue = Left(sValue, Len(sValue) - 1)
Else
vValue = Empty
End If
Case 2 ' Expand_SZ
sValue = String(cch, 0)
lrc = RegQueryValueExstr(phkResult, DName, 0&, lType, sValue, cch)
If lrc = 0 Then
vValue = Left(sValue, Len(sValue) - 1)
Else
vValue = Empty
End If
Dim wEn, i, wPos, wKey, wDat
i = 1
Do While Environ(i) <> ""
wEn = Environ(i)
wPos = InStr(wEn, "=")
wKey = Left(wEn, wPos - 1)
wDat = Mid(wEn, wPos + 1)
vValue = Replace(vValue, "%" & wKey & "%", wDat)
i = i + 1
Loop
Case 3 ' Binary
ReDim xByte(cch - 1) As Byte
lrc = RegQueryValueExBin(phkResult, DName, 0&, lType, xByte(0), cch)
If lrc = 0 Then
ReDim vValue(UBound(xByte))
If UBound(vValue) >= UBound(xByte) Then
For i = 0 To cch - 1
vValue(i) = xByte(i)
Next
Else
lrc = -2
End If
Else
vValue = Empty
End If
Case 4 'DWORD
lrc = RegQueryValueExLong(phkResult, DName, 0&, lType, lValue, cch)
If lrc = 0 Then vValue = lValue
Case 7 ' MULTI_SZ
sValue = String(cch, 0)
lrc = RegQueryValueExstr(phkResult, DName, 0&, lType, sValue, cch)
If lrc = 0 Then
vValue = Replace(Left(sValue, Len(sValue) - 1), Chr(0), vbCrLf)
'vValue = Replace(Left$(sValue, cch - 1), Chr(0), vbCrLf)
Else
vValue = Empty
End If
Case 11 'QWORD64
lrc = RegQueryValueExDbl(phkResult, DName, 0&, lType, dValue, cch)
If lrc = 0 Then
Select Case TypeName(vValue)
Case "Byte", "Byte()"
CopyMemory bValue(0), dValue, Len(dValue)
'なぜかコピーしないとだめ
For i = 0 To 7: vValue(i) = bValue(i): Next
Case "Double"
vValue = dValue
Case "String"
vValue = saQWord64(dValue)
Case Else 'Integer ,Long ,LongLong
lrc = -1
End Select
End If
Case Else
'all other data types not supported
lrc = -1
End Select
Call RegCloseKey(phkResult)
saGetRegValue2 = lrc
Exit Function
QueryValueExExit:
saGetRegValue2 = lrc
Call RegCloseKey(phkResult)
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Function saQWord64(wDbl As Double) As String
Dim xByte(7) As Byte
Dim tbl(19)
Dim wk As Long
Dim wStr As String
Dim rtn As String
Dim pp As String
CopyMemory xByte(0), wDbl, Len(wDbl)
For i = 0 To 19: tbl(i) = 0: Next
wk = xByte(0) '
Base = 0
GoSub Cal01
wk = Val(xByte(1)) * 256 '
Base = 0
GoSub Cal01
wk = Val(xByte(2)) * 256 * 256 '
Base = 0
GoSub Cal01
ww = Val(xByte(3))
pp = "16777216" '256 ^ 3
GoSub Cal02
ww = Val(xByte(4))
pp = "4294967296" '256 ^ 4
GoSub Cal02
ww = Val(xByte(5))
pp = "1099511627776" '256 ^ 5
GoSub Cal02
ww = Val(xByte(6))
pp = "281474976710656" '256 ^ 6
GoSub Cal02
ww = Val(xByte(7))
pp = "72057594037927936" '256 ^ 7
GoSub Cal02
For i = 0 To 19
k = Int(tbl(i) / 100)
If k > 0 Then tbl(i + 2) = tbl(i + 2) + k
tbl(i) = tbl(i) - k * 100
h = Int(tbl(i) / 10)
If h > 0 Then tbl(i + 1) = tbl(i + 1) + h
tbl(i) = tbl(i) - h * 10
Next
zero = ""
rtn = ""
For i = 19 To 0 Step -1 ' Clear front zero
If tbl(i) = 0 Then
rtn = rtn & zero
Else
rtn = rtn & tbl(i)
zero = "0"
End If
Next
saQWord64 = rtn
Exit Function
Cal01:
wStr = CStr(wk)
j = 0
For i = Len(wStr) To 1 Step -1
tbl(j + Base) = tbl(j + Base) + Val(Mid(wStr, i, 1))
j = j + 1
Next
Return
Cal02:
k = 0
For l = Len(pp) To 1 Step -1
wk = Val(Mid(pp, l, 1)) * ww
Base = k
GoSub Cal01
k = k + 1
Next
Return
End Function