regapi.bas

此文档为VB公共模块

Attribute VB_Name = "RegAPI"
Option Explicit
'注册表
'****************Regster API Function**************
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 RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
' Note that if you declare the lpData parameter as String, you must pass it By Value.
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, ByVal lpData As String, 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
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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 Any) 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, lpType As Long, lpData As Byte, lpcbData As Long) As Long
'*************************All Consts****************
Public Enum RegMainKey
    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 RegValueType
    REG_SZ = 1&
    REG_EXPAND_SZ = 2&
    REG_BINARY = 3
    REG_DWORD = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_LINK = 6
    REG_MULTI_SZ = 7
End Enum

'***********************
'Write to Regster Table*
'***********************
'注意:该项函数只能写入字符串值.包括REG_SZ,REG_MULTI_SZ两种类型.
Public Function WriteReg(ByVal MainKey As RegMainKey, ByVal SubKey As String, Optional ByVal ValueName As String, Optional ByVal Value As String, Optional ByVal ValueType As RegValueType) As Boolean
    Dim KeyHandle As Long, str_Temp As String
    If ValueType = 0 Then ValueType = REG_SZ
    Select Case ValueType
    Case REG_SZ
        Value = CStr(Value)
    Case REG_MULTI_SZ
        Value = Value + String(2, Chr(0))
    Case REG_DWORD
    Case Else
    End Select
    If RegCreateKey(MainKey, SubKey, KeyHandle) = 0 Then WriteReg = RegSetValueEx(KeyHandle, ValueName, 0&, ValueType, Value, Len(Value)) = 0
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
End Function
'***********************
'Read Value            *
'***********************
Public Function ReadValue(ByVal MainKey As RegMainKey, ByVal SubKey As String, ByVal ValueName As String) As Variant
    'Get RegKey Handle
    Dim KeyHandle As Long
    If RegOpenKey(MainKey, SubKey, KeyHandle) <> 0 Then Exit Function

    Dim lng_Result As Long, lng_ValueType As RegValueType, str_DataBuffer As String, lng_DataBufSize As Long, lng_DataBuffer As Long
    'retrieve iformation about the key
    lng_Result = RegQueryValueEx(KeyHandle, ValueName, 0, lng_ValueType, ByVal 0, lng_DataBufSize)
    If lng_Result = 0 Then
        Select Case lng_ValueType
        Case REG_SZ, REG_MULTI_SZ
            'Create a buffer
            str_DataBuffer = String(lng_DataBufSize, Chr$(0))
            'retrieve the key's content
            lng_Result = RegQueryValueEx(KeyHandle, ValueName, 0, 0, ByVal str_DataBuffer, lng_DataBufSize)
            If lng_Result = 0 Then
                'Remove the unnecessary chr$(0)'s
                ReadValue = Left$(str_DataBuffer, InStr(1, str_DataBuffer, Chr$(0)) - 1)
            End If
        Case REG_BINARY, REG_DWORD
            'retrieve the key's value
            lng_Result = RegQueryValueEx(KeyHandle, ValueName, 0, 0, lng_DataBuffer, lng_DataBufSize)
            If lng_Result = 0 Then
                ReadValue = lng_DataBuffer
            End If
        End Select
    End If
    
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
End Function
'********************
'Delete From Regster*
'********************
Public Function DelReg(ByVal MainKey As RegMainKey, ByVal SubKey As String, ByVal SubKeyOrValueName As String, ByVal IsKey As Boolean) As Boolean
    If Trim$(SubKeyOrValueName) = "" Then Exit Function
    Dim KeyHandle As Long
    If RegCreateKey(MainKey, SubKey, KeyHandle) = 0 Then DelReg = IIf(IsKey, RegDeleteKey(KeyHandle, SubKeyOrValueName), RegDeleteValue(KeyHandle, SubKeyOrValueName)) = 0
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
End Function
'********************
'Enum Key           *
'********************
Public Function EnumKey(ByVal MainKey As RegMainKey, ByVal SubKey As String) As String()
    Dim KeyHandle As Long, int_Cnt As Integer, str_Save As String, str_Result() As String
    Dim int_ZeroPos As Integer
    ReDim str_Result(1024) As String
    int_Cnt = 0
    '创建注册表操作句柄
    If RegOpenKey(MainKey, SubKey, KeyHandle) = 0 Then
        Do
            If int_Cnt = 1024 Then Exit Do
            str_Save = String(255, Chr(0))
            '枚举注册表键
            If RegEnumKeyEx(KeyHandle, int_Cnt, str_Save, 255, 0, vbNullString, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
            '从返回的结果串中去除vbNullChar
            int_ZeroPos = InStr(1, str_Save, vbNullChar)
            If int_ZeroPos > 0 Then
                str_Result(int_Cnt) = Left$(str_Save, int_ZeroPos - 1)
            Else
                str_Result(int_Cnt) = str_Save
            End If
            '计数器加1
            int_Cnt = int_Cnt + 1
        Loop
    End If
    '关闭句柄
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
    '从新定义数组大小并返回结果
    ReDim Preserve str_Result(int_Cnt - 1)
    EnumKey = str_Result
End Function

'********************
'Enum Value         *
'********************
Public Function EnumValue(ByVal MainKey As RegMainKey, ByVal SubKey As String) As String()
    Dim KeyHandle As Long, int_Cnt As Integer, str_Save As String, str_Result() As String
    Dim int_ZeroPos As Integer
    ReDim str_Result(1024) As String
    int_Cnt = 0
    '创建注册表操作句柄
    If RegOpenKey(MainKey, SubKey, KeyHandle) = 0 Then
        Do
            If int_Cnt = 1024 Then Exit Do
            str_Save = String(255, Chr(0))
            '枚举注册表键
            If RegEnumValue(KeyHandle, int_Cnt, str_Save, 255, 0, ByVal 0&, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
            '从返回的结果串中去除vbNullChar
            int_ZeroPos = InStr(1, str_Save, vbNullChar)
            If int_ZeroPos > 0 Then
                str_Result(int_Cnt) = Left$(str_Save, int_ZeroPos - 1)
            Else
                str_Result(int_Cnt) = str_Save
            End If
            '计数器加1
            int_Cnt = int_Cnt + 1
        Loop
    End If
    '关闭句柄
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
    '从新定义数组大小并返回结果
    ReDim Preserve str_Result(int_Cnt - 1)
    EnumValue = str_Result
End Function

Public Function WriteReg1(ByVal MainKey As RegMainKey, ByVal SubKey As String, Optional ByVal ValueName As String, Optional ByVal Value As String, Optional ByVal ValueType As RegValueType) As Boolean
    Dim KeyHandle As Long, str_Temp As String, str_Bytes(3) As Byte
    If ValueType = 0 Then ValueType = REG_SZ
    Select Case ValueType
    Case REG_SZ
        Value = Value
    Case REG_MULTI_SZ
        Value = Value + String(2, Chr(0))
    Case REG_DWORD
        str_Bytes(3) = (Val(Value) And 2130706432) / (2 ^ 24)
        str_Bytes(2) = (Val(Value) And 16711680) / (2 ^ 16)
        str_Bytes(1) = (Val(Value) And 65280) / (2 ^ 8)
        str_Bytes(0) = Val(Value) And &HFF
        Debug.Print Asc(Left(Value, 1)) & "," & Asc(Mid(Value, 2, 1)) & "," & Asc(Mid(Value, 3, 1)) & "," & Asc(Right(Value, 1))
    Case Else
    End Select
    If RegCreateKey(MainKey, SubKey, KeyHandle) = 0 Then WriteReg1 = RegSetValueEx(KeyHandle, ValueName, 0&, ValueType, str_Bytes, 4) = 0
    If KeyHandle <> 0 Then RegCloseKey KeyHandle
End Function