.另存為IRegister.CLA文件
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "IRegister"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'masks for the predefined standard access types
Private Const SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
'Registry Specific Access Rights
Private Const KEY_EVENT = &H1
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = (KEY_READ)
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
'Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1
'Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2
'Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 ' dderror
Private Const ERROR_NO_MORE_ITEMS = 259
'Value Type
Private Const REG_NONE = (0) 'No value type
Private Const REG_SZ = (1) 'Unicode nul terminated string
Private Const REG_EXPAND_SZ = (2) 'Unicode nul terminated string w/enviornment var
Private Const REG_BINARY = (3) 'Free form binary
Private Const REG_DWORD = (4) '32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN = (4) '32-bit number (same as REG_DWORD)
Private Const REG_DWORD_BIG_ENDIAN = (5) '32-bit number
Private Const REG_LINK = (6) 'Symbolic Link (unicode)
Private Const REG_MULTI_SZ = (7) 'Multiple Unicode strings
Private Const REG_RESOURCE_LIST = (8) 'Resource list in the resource map
Private Const REG_FULL_RESOURCE_DESCRIPTOR = (9) 'Resource list in the hardware description
Private Const REG_RESOURCE_REQUIREMENTS_LIST = (10)
'Registry Declare
Private Declare Function RegRemoveKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegRemoveValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, ByVal lpData As Long, ByVal lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Enum RegHeadKeyConstants
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
Public Enum RegValueTypeConstants
regNone = REG_NONE
regString = REG_SZ
regExpandString = REG_EXPAND_SZ
regBinary = REG_BINARY
regDWORD = REG_DWORD
regDWORDLittleEndian = REG_DWORD_LITTLE_ENDIAN
regDWORDBigEndian = REG_DWORD_BIG_ENDIAN
regLink = REG_LINK
regMultiString = REG_MULTI_SZ
regResourceList = REG_RESOURCE_LIST
regFullResourceDescriptor = REG_FULL_RESOURCE_DESCRIPTOR
regResourceRequirementsList = REG_RESOURCE_REQUIREMENTS_LIST
End Enum
Private CHKey As Long
Private CH_RT As Long
Private Function SwapEndian(ByVal dw As Long) As Long
CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
Private Function ExpandEnvStr(sData As String) As String
Dim c As Long, s As String
' Get the length
s = "" ' Needed to get around Windows 95 limitation
c = ExpandEnvironmentStrings(sData, s, c)
' Expand the string
s = String$(c - 1, 0)
c = ExpandEnvironmentStrings(sData, s, c)
ExpandEnvStr = s
End Function
Private Sub CheckRegErr()
If CHKey = 0 Then
Err.Raise 1500, "Register", "未打開註冊表。"
End If
End Sub
Property Get Handle() As OLE_HANDLE
Attribute Handle.VB_UserMemId = 0
Handle = CHKey
End Property
Public Function FreeRegister() As Long
If CHKey <> 0 Then
FreeRegister = RegCloseKey(CHKey)
CHKey = 0
End If
End Function
Public Function OpenRegister(hKey As RegHeadKeyConstants, Optional SubKey As String) As Long
Dim lCreate As Long, tSA As SECURITY_ATTRIBUTES
Dim rt As Long
FreeRegister
rt = RegCreateKeyEx(hKey, SubKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, tSA, CHKey, lCreate)
OpenRegister = rt 'set return value
CH_RT = rt
If rt Then
Err.Raise 26001, "Registry", "打開註冊表失敗。"
Else
OpenRegister = True
End If
End Function
Public Function RemoveRegKey(hKey As RegHeadKeyConstants, SubKey As String) As Long
RemoveRegKey = RegRemoveKey(hKey, SubKey)
End Function
Public Function RemoveRegValue(Optional ValueName As String) As Long
CheckRegErr
RemoveRegValue = RegRemoveValue(CHKey, ValueName)
End Function
Public Function EnumValues(ByRef sKeyNames() As String, ByRef iKeyCount As Long) As Boolean
CheckRegErr
Dim lResult As Long
Dim sName As String
Dim lNameSize As Long
Dim sData As String
Dim lIndex As Long
Dim cJunk As Long
Dim cNameMax As Long
Dim ft As Currency
' Log "EnterEnumerateValues"
iKeyCount = 0
Erase sKeyNames()
lIndex = 0
lResult = CH_RT
If (lResult = ERROR_SUCCESS) Then
' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
lResult = RegQueryInfoKey(CHKey, "", cJunk, 0, _
cJunk, cJunk, cJunk, cJunk, _
cNameMax, cJunk, cJunk, ft)
Do While lResult = ERROR_SUCCESS
'Set buffer space
lNameSize = cNameMax + 1
sName = String$(lNameSize, 0)
If (lNameSize = 0) Then lNameSize = 1
' Log "Requesting Next Value"
'Get value name:
lResult = RegEnumValue(CHKey, lIndex, sName, lNameSize, _
0&, 0&, 0&, 0&)
' Log "RegEnumValue returned:" & lResult
If (lResult = ERROR_SUCCESS) Then
' Although in theory you can also retrieve the actual
' value and type here, I found it always (ultimately) resulted in
' a GPF, on Win95 and NT. Why? Can anyone help?
sName = Left$(sName, lNameSize)
' Log "Enumerated value:" & sName
iKeyCount = iKeyCount + 1
ReDim Preserve sKeyNames(1 To iKeyCount) As String
sKeyNames(iKeyCount) = sName
End If
lIndex = lIndex + 1
Loop
End If
' Log "Exit Enumerate Values"
EnumValues = True
Exit Function
EnumValuesError:
Err.Raise vbObjectError + 1048 + 26003, "Registry", Err.Description
Exit Function
End Function
Public Function EnumSections(ByRef sSect() As String, ByRef iSectCount As Long) As Boolean
CheckRegErr
Dim lResult As Long
Dim dwReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
Dim iPos As Long
On Error GoTo EnumSectionsError
iSectCount = 0
Erase sSect
'
lIndex = 0
lResult = CH_RT
Do While lResult = ERROR_SUCCESS
'Set buffer space
szBuffer = String$(255, 0)
lBuffSize = Len(szBuffer)
'Get next value
lResult = RegEnumKey(CHKey, lIndex, szBuffer, lBuffSize)
If (lResult = ERROR_SUCCESS) Then
iSectCount = iSectCount + 1
ReDim Preserve sSect(1 To iSectCount) As String
iPos = InStr(szBuffer, Chr$(0))
If (iPos > 0) Then
sSect(iSectCount) = Left(szBuffer, iPos - 1)
Else
sSect(iSectCount) = Left(szBuffer, lBuffSize)
End If
End If
lIndex = lIndex + 1
Loop
EnumSections = True
Exit Function
EnumSectionsError:
Err.Raise vbObjectError + 1048 + 26002, "Registry", Err.Description
Exit Function
End Function
Public Function ValueExist(Optional ValueName As String) As Boolean
Dim lenData As Long, rt As Long, rgtype As Long
rt = RegQueryValueEx(CHKey, ValueName, 0, rgtype, ByVal vbNullString, lenData)
If rt = 0 Then
ValueExist = True
Else
ValueExist = False
End If
End Function
Public Function ReadRegType(Optional ValueName As String) As RegValueTypeConstants
CheckRegErr
Dim l As Long, rt As Long, rgtype As Long
rt = RegQueryValueEx(CHKey, ValueName, 0, rgtype, ByVal vbNullString, l)
ReadRegType = rgtype
End Function
Public Function ReadRegValue(Optional ValueName As String, Optional ValueType As RegValueTypeConstants)
CheckRegErr
Dim lenData As Long, rt As Long, rgtype As Long
Dim Str As String, dw As Long, bin() As Byte
rt = RegQueryValueEx(CHKey, ValueName, 0, rgtype, ByVal vbNullString, lenData)
If rt And rt <> ERROR_MORE_DATA Then
Err.Raise rt, "Register", "無法讀取。" & vbCrLf & "錯誤號：" & rt
Exit Function
End If
ValueType = rgtype ' return the value's type
Select Case rgtype
Case REG_SZ, REG_MULTI_SZ
Str = String(lenData, Chr(0))
rt = RegQueryValueExStr(CHKey, ValueName, 0, rgtype, ByVal Str, lenData)
ReadRegValue = Left(Str, lenData - 1)
Case REG_EXPAND_SZ
Str = String(lenData, Chr(0))
rt = RegQueryValueExStr(CHKey, ValueName, 0, rgtype, ByVal Str, lenData)
ReadRegValue = ExpandEnvStr(Left(Str, lenData - 1))
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
rt = RegQueryValueExLong(CHKey, ValueName, 0, rgtype, ByVal dw, lenData)
ReadRegValue = CLng(dw)
Case REG_DWORD_BIG_ENDIAN
rt = RegQueryValueExLong(CHKey, ValueName, 0, rgtype, ByVal dw, lenData)
ReadRegValue = SwapEndian(dw)
Case REG_BINARY
ReDim bin(lenData)
rt = RegQueryValueExByte(CHKey, ValueName, 0&, rgtype, bin(0), lenData)
ReadRegValue = bin
End Select
End Function
Public Function WriteRegValue(Optional ValueName As String, Optional vValue, Optional ValueType As RegValueTypeConstants = REG_SZ) As Long
CheckRegErr
Dim ordType As Long, c As Long, e As Long
Select Case ValueType
Case REG_BINARY
If (varType(vValue) = vbArray + vbByte) Then
Dim ab() As Byte
ab = vValue
ordType = REG_BINARY
c = UBound(ab) - LBound(ab) - 1
e = RegSetValueExByte(CHKey, ValueName, 0&, ordType, ab(0), c)
Else
Err.Raise 26001
End If
Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
If (varType(vValue) = vbInteger) Or (varType(vValue) = vbLong) Then
Dim i As Long
i = vValue
ordType = REG_DWORD
e = RegSetValueExLong(CHKey, ValueName, 0&, ordType, i, 4)
End If
Case REG_SZ, REG_EXPAND_SZ
Dim s As String, iPos As Long
s = vValue
ordType = REG_SZ
' Assume anything with two non-adjacent percents is expanded string
iPos = InStr(s, "%")
If iPos Then
If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
End If
c = Len(s) + 1
e = RegSetValueExStr(CHKey, ValueName, 0&, ordType, s, c)
' User should convert to a compatible type before calling
Case Else
e = ERROR_INVALID_DATA
End Select
End Function