regprocess.bas

来自「一个clock的 vb 源码」· BAS 代码 · 共 133 行

Attribute VB_Name = "RegProcess"
Option Explicit
'-------------------------------------------------------------------------------
' Registry Functions
' RegCreateKeyEx        在指定项下创建新的注册表项
' RegSetValueEx         用于设置指定项的值
' RegOpenKeyEx          在指定的项下创建或打开一个项
' RegQueryValueEx       用于获取一个项的设置值
' RegCloseKey           用于关闭系统注册表中的一个项（或键）
' RegDeleteKey          删除现有项下方一个指定的子项
' RegDeleteValue        删除指定项下方的一个值
'-------------------------------------------------------------------------------
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" 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

Public Declare Function RegSetValueExAny Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Any, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExString 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

Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, lpData As Long, ByRef pcbData As Long) As Long
Public Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Public 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

Public 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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'--------------------------------------------------------------------------------

Public Function CreateRegKey(KeyRoot As Long, lpSubKey As String, lpValueName As String, ValueType As Long, SubKeyValue As Variant) As Boolean
    Dim lpAttr As SECURITY_ATTRIBUTES
    Dim hKey As Long, RValues As Long, lpdwDisposition As Long
    
    lpAttr.nLength = 50                  ' 设置安全属性为缺省值...
    lpAttr.lpSecurityDescriptor = 0          ' ...
    lpAttr.bInheritHandle = True
        
        RValues = RegCreateKeyEx(KeyRoot, lpSubKey, 0&, "", REG_OPTION_NON_VOLATILE, _
                  KEY_ALL_ACCESS, lpAttr, hKey, lpdwDisposition)
        If (RValues <> ERROR_SUCCESS) Then: GoTo CreateKeyError
    
    Select Case ValueType
        Case REG_SZ
            RValues = RegSetValueExString(hKey, lpValueName, 0&, ValueType, SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
            If (RValues <> ERROR_SUCCESS) Then: GoTo CreateKeyError
        Case REG_DWORD
            RValues = RegSetValueExLong(hKey, lpValueName, 0&, ValueType, SubKeyValue, 4)
            If (RValues <> ERROR_SUCCESS) Then: GoTo CreateKeyError
    End Select
    Call RegCloseKey(hKey)
    CreateRegKey = True
    Exit Function
CreateKeyError:
    Call RegCloseKey(hKey)
    CreateRegKey = False
End Function

Public Function GetReghKey(KeyRoot As Long, KeyName As String) As Long
    Dim ReturnValues As Long
    Dim hKey As Long
    ReturnValues = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
    If ReturnValues <> 0 Then
        GetReghKey = 0
        Call RegCloseKey(hKey)
        Exit Function
    Else
        GetReghKey = hKey
    End If
   
End Function

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As Variant
    Dim hKey As Long
    Dim hDepth As Long
    Dim RValues As Long
    Dim lKeyValType As Long             ' 数据类型
   
    Dim tmpVal As String                ' 临时存储器
    Dim KeyValSize As Long              ' 变量尺寸
    Dim sKeyVal As String
    
    ' 打开注册表关键字
    RValues = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
    If (RValues <> ERROR_SUCCESS) Then: GoTo GetKeyError   ' 处理错误...
    
    tmpVal = String$(1024, 0)                             ' 分配变量空间
    KeyValSize = 1024                                      ' 标记变量尺寸
    
    Call RegQueryValueExString(hKey, SubKeyRef, 0&, lKeyValType, tmpVal, KeyValSize)
    Select Case lKeyValType                                 '
        Case REG_SZ
            GetKeyValue = Left$(tmpVal, InStr(tmpVal, vbNullChar) - 1)
        Case REG_DWORD
            Call RegQueryValueEx(hKey, SubKeyRef, 0, lKeyValType, hDepth, 4)
            GetKeyValue = CStr(hDepth)
        Case REG_BINARY
            Dim ByteData() As Byte
            ReDim ByteData(KeyValSize) '(KeyValSize 从1开始算即(01 01 01 01)为4而不是3)
            Call RegQueryValueExByte(hKey, SubKeyRef, 0&, lKeyValType, ByteData(0), KeyValSize)
            GetKeyValue = ByteData
        End Select
        Call RegCloseKey(hKey)
    Exit Function
GetKeyError:
    GetKeyValue = vbNullString
    Call RegCloseKey(hKey)
End Function

Public Function DelRegkey(KeyRoot As Long, lpSubKey As String, SubKeyName As String) As Boolean
    Dim hKey As Long, RValue As Long
    RValue = RegOpenKeyEx(KeyRoot, lpSubKey, 0, KEY_ALL_ACCESS, hKey)
    RValue = RegDeleteKey(hKey, SubKeyName)
    If RValue <> 0 Then
        Call RegCloseKey(hKey)
        Exit Function
    End If
    Call RegCloseKey(hKey)
End Function

Public Function DelRegSubkey(KeyRoot As Long, lpSubKey As String, lpValueName As String) As Boolean
    Dim hKey As Long, RValue As Long
    RValue = RegOpenKeyEx(KeyRoot, lpSubKey, 0, KEY_ALL_ACCESS, hKey)
    If RValue <> 0 Then: GoTo DelResError
    Call RegDeleteValue(hKey, lpValueName)
    Call RegCloseKey(hKey)
    Exit Function
DelResError:
    Call RegCloseKey(hKey)
    DelRegSubkey = False
End Function