平特肖公式规律|真虎骨平特肖114|
5個免費課程
網站公告
·Access快速平臺QQ群號:156702533    ·Access快速開發平臺下載地址及教程    ·歡迎添加微信交流賬號:AccessoftChu    ·如何快速搜索本站文章|示例|資料    
您的位置: 首頁 > 技術文章 > Access數據庫-模塊/函數/VBA

Access VBA 注冊表操作源碼

時 間:2018-01-08 08:10:25
作 者:網絡   ID:47512  城市:南京
摘 要:Access VBA 注冊表操作源碼
正 文:

注冊表存放著系統和應用程序的信息。一般情況下我們是不能去動的。如何利用VBA代碼編輯注冊表呢?包括增加、減少項及子項;增加、減少值;改寫項、值等等。注冊表操作,網上找了些,只有黃海的,但是運行時有問題,從VB中找了一個,在ACCESS中可以運行,現作為一個包提供給大家。

大家可以作成模塊,用時方便

詳細代碼:

Option Explicit

Option Compare Text

'---------------------------------------------------------------
'- 注冊表 API 聲明…
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private 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
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 RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) 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 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 RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hkey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hkey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) 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
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 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, lpType As Long, lpData As Byte, 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 AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long                'Used to adjust your program's security privileges, can't restore without it!
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpLuid As LUID) As Long          'Returns a valid LUID which is important when making security changes in NT.
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

'---------------------------------------------------------------
'- 注冊表 Api 常數…
'---------------------------------------------------------------
' 注冊表創建類型值…
Const REG_OPTION_NON_VOLATILE = 0        ' 當系統重新啟動時,關鍵字被保留

' 注冊表關鍵字安全選項…
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_Create_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_Create_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_Create_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_Create_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_Create_LINK + READ_CONTROL
                     
' 返回值…
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0

' 有關導入/導出的常量
Const REG_FORCE_RESTORE As Long = 8&
Const TOKEN_QUERY As Long = &H8&
Const TOKEN_ADJUST_PRIVILEGES As Long = &H20&
Const SE_PRIVILEGE_ENABLED As Long = &H2
Const SE_RESTORE_NAME = "SeRestorePrivilege"
Const SE_BACKUP_NAME = "SeBackupPrivilege"

'---------------------------------------------------------------
'- 注冊表類型…
'---------------------------------------------------------------
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

Private Type LUID
    lowpart As Long
    highpart As Long
End Type

Private Type LUID_AND_ATTRIBUTES
    pLuid As LUID
    Attributes As Long
End Type

Private Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges As LUID_AND_ATTRIBUTES
End Type

'---------------------------------------------------------------
'- 自定義枚舉類型…
'---------------------------------------------------------------
' 注冊表數據類型…
Public Enum EM_RegVarType
    REG_NONE = 0                       ' No value type
    REG_SZ = 1                         ' 字符串值
    REG_EXPAND_SZ = 2                  ' 可擴充字符串值
    REG_BINARY = 3                     ' 二進制值
    REG_DWORD = 4                      ' DWORD值
    REG_DWORD_BIG_ENDIAN = 5           ' 32-bit number
    REG_LINK = 6                       ' Symbolic Link (unicode)
    REG_MULTI_SZ = 7                   ' 多字符串值
    REG_RESOURCE_LIST = 8              ' Resource list in the resource map
End Enum

' 注冊表關鍵字根類型…
Public Enum EM_RegRootKey
  HKEY_CLASSES_ROOT = &H80000000
  HKEY_CURRENT_USER = &H80000001
  HKEY_LOCAL_MACHINE = &H80000002
  HKEY_USERS = &H80000003
  HKEY_PERFORMANCE_DATA = &H80000004 '64系統位專用
  HKEY_CURRENT_CONFIG = &H80000005
  HKEY_DYN_DATA = &H80000006 '32位系統專用
End Enum

Private hkey As Long                   ' 注冊表打開項的句柄
Private I As Long, j As Long           ' 循環變量
Private Success As Long                ' API函數的返回值, 判斷函數調用是否成功

'-------------------------------------------------------------------------------------------------------------
'- 新建注冊表關鍵字并設置注冊表關鍵字的值…
'- 如果 ValueName 和 Value 都缺省, 則只新建 KeyName 空項, 無子鍵…
'- 如果只缺省 ValueName 則將設置指定 KeyName 的默認值
'- 參數說明: KeyRoot--根類型, KeyName--子項名稱, ValueName--值項名稱, Value--值項數據, ValueType--值項類型
'-------------------------------------------------------------------------------------------------------------
Public Function SetKeyValue(KeyRoot As EM_RegRootKey, KeyName As String, Optional ValueName As String, Optional Value As Variant = "", Optional ValueType As EM_RegVarType = REG_SZ) As Boolean
    Dim lpAttr As SECURITY_ATTRIBUTES                   ' 注冊表安全類型
    lpAttr.nLength = 50                                 ' 設置安全屬性為缺省值…
    lpAttr.lpSecurityDescriptor = 0                     ' …
    lpAttr.bInheritHandle = True                        ' …
    
    ' 新建注冊表關鍵字…
    Success = RegCreateKeyEx(KeyRoot, KeyName, 0, ValueType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hkey, 0)
    If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hkey: Exit Function
    
    ' 設置注冊表關鍵字的值…
    If IsMissing(ValueName) = False Then
        Select Case ValueType
            Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ, REG_NONE
                Success = RegSetValueEx(hkey, ValueName, 0, ValueType, ByVal CStr(Value), LenB(StrConv(Value, vbFromUnicode)) + 1)
            Case REG_DWORD
                If CDbl(Value) <= and="">= 0 Then
                    Dim sValue As String
                    sValue = DoubleToHex(Value)
                    Dim dValue(3) As Byte
                    dValue(0) = Format("&h" & Mid(sValue, 7, 2))
                    dValue(1) = Format("&h" & Mid(sValue, 5, 2))
                    dValue(2) = Format("&h" & Mid(sValue, 3, 2))
                    dValue(3) = Format("&h" & Mid(sValue, 1, 2))
                    Success = RegSetValueEx(hkey, ValueName, 0, ValueType, dValue(0), 4)
                Else
                    Success = ERROR_BADKEY
                End If
            Case REG_BINARY
                On Error Resume Next
                Success = 1                             ' 假設調用API不成功(成功返回0)
                ReDim tmpValue(Ubound(Value)) As Byte
                For I = 0 To Ubound(tmpValue)
                    tmpValue(i) = Value(i)
                Next I
                Success = RegSetValueEx(hkey, ValueName, 0, ValueType, tmpValue(0), Ubound(Value) + 1)
        End Select
    End If
    If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hkey: Exit Function
    
    ' 關閉注冊表關鍵字…
    RegCloseKey hkey
    SetKeyValue = True                                       ' 返回函數值
End Function

'-------------------------------------------------------------------------------------------------------------
'- 獲得已存在的注冊表關鍵字的值…
'- 如果 ValueName="" 則返回 KeyName 項的默認值…
'- 如果指定的注冊表關鍵字不存在, 則返回空串…
'- 參數說明: KeyRoot--根類型, KeyName--子項名稱, ValueName--值項名稱, ValueType--值項類型
'-------------------------------------------------------------------------------------------------------------
Public Function GetKeyValue(KeyRoot As EM_RegRootKey, KeyName As String, Optional ValueName As String = "", Optional ValueType As EM_RegVarType) As String
    Dim TempValue As String                             ' 注冊表關鍵字的臨時值
    Dim Value As String                                 ' 注冊表關鍵字的值
    Dim ValueSize As Long                               ' 注冊表關鍵字的值的實際長度
    TempValue = Space(1024)                             ' 存儲注冊表關鍵字的臨時值的緩沖區
    ValueSize = 1024                                    ' 設置注冊表關鍵字的值的默認長度
    
    ' 打開一個已存在的注冊表關鍵字…
    RegOpenKeyEx KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hkey
    
    ' 獲得已打開的注冊表關鍵字的值…
    RegQueryValueEx hkey, ValueName, 0, ValueType, ByVal TempValue, ValueSize
    
    ' 返回注冊表關鍵字的的值…
    Select Case ValueType                                                        ' 通過判斷關鍵字的類型, 進行處理
        Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_NONE
            TempValue = Left$(TempValue, ValueSize - 1)                          ' 去掉TempValue尾部空格
            Value = TempValue
        Case REG_DWORD
            ReDim dValue(3) As Byte
            RegQueryValueEx hkey, ValueName, 0, REG_DWORD, dValue(0), ValueSize
            For I = 3 To 0 Step -1
                Value = Value + String(2 - Len(Hex(dValue(i))), "0") + Hex(dValue(i))   ' 生成長度為8的十六進制字符串
            Next I
            If CDbl("&H" & Value) < 0 Then                                              ' 將十六進制的 Value 轉換為十進制
                Value = 2 ^ 32 + CDbl("&H" & Value)
            Else
                Value = CDbl("&H" & Value)
            End If
        Case REG_BINARY
            If ValueSize > 0 Then
                ReDim bValue(ValueSize - 1) As Byte                                     ' 存儲 REG_BINARY 值的臨時數組
                RegQueryValueEx hkey, ValueName, 0, REG_BINARY, bValue(0), ValueSize
                For I = 0 To ValueSize - 1
                    Value = Value + String(2 - Len(Hex(bValue(i))), "0") + Hex(bValue(i)) + " "  ' 將數組轉換成字符串
                Next I
            End If
    End Select
    
    ' 關閉注冊表關鍵字…
    RegCloseKey hkey
    GetKeyValue = Trim(Value)                                                    ' 返回函數值
End Function

'-------------------------------------------------------------------------------------------------------------
'- 刪除已存在的注冊表關鍵字的值…
'- 如果指定的注冊表關鍵字不存在, 則不做任何操作…
'- 參數說明: KeyRoot--根類型, KeyName--子項名稱, ValueName--值項名稱
'-------------------------------------------------------------------------------------------------------------
Public Function DeleteKey(KeyRoot As EM_RegRootKey, KeyName As String, Optional ValueName As String) As Boolean
    Dim tmpKeyName As String                            ' 注冊表關鍵字的臨時子項名稱
    Dim tmpValueName As String                          ' 注冊表關鍵字的臨時子鍵名稱
    
    ' 打開一個已存在的注冊表關鍵字…
    Success = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hkey)
    If Success <> ERROR_SUCCESS Then DeleteKey = False: RegCloseKey hkey: Exit Function
    
    ' 刪除已打開的注冊表關鍵字…
    tmpKeyName = ""
    tmpValueName = KeyName
    If ValueName = "" Then                                              ' 判斷ValueName是否缺省, 如缺省作相應處理
        If InStrRev(KeyName, "\") > 1 Then
            tmpValueName = Right(KeyName, InStrRev(KeyName, "\") + 1)
            tmpKeyName = Left(KeyName, InStrRev(KeyName, "\") - 1)
        End If
        Success = RegOpenKeyEx(KeyRoot, tmpKeyName, 0, KEY_ALL_ACCESS, hkey)
        Success = RegDeleteKey(hkey, tmpValueName)
    Else
        Success = RegDeleteValue(hkey, ValueName)
    End If
    If Success <> ERROR_SUCCESS Then DeleteKey = False: RegCloseKey hkey: Exit Function
    
    ' 關閉注冊表關鍵字…
    RegCloseKey hkey
    DeleteKey = True                                    ' 返回函數值
End Function

Function DeleteSubkeyTree(ByVal hkey As Long, ByVal Subkey As String) As Boolean
    Dim ret As Long, Index As Long, Name As String
    Dim hSubkey As Long
    
    ret = RegOpenKey(hkey, Subkey, hSubkey)
    If ret <> 0 Then
        DeleteSubkeyTree = False
        Exit Function
    End If
    ret = RegDeleteKey(hSubkey, "")
    If ret <> 0 Then
        Name = String(256, Chr(0))
        While RegEnumKey(hSubkey, 0, Name, Len(Name)) = 0 And _
              DeleteSubkeyTree(hSubkey, Name)
        Wend
        ret = RegDeleteKey(hSubkey, "")
    End If
    DeleteSubkeyTree = (ret = 0)
    RegCloseKey hSubkey
End Function

'-------------------------------------------------------------------------------------------------------------
'- 導出注冊表關鍵字的值
'- 參數說明: KeyRoot--根類型, KeyName--子項名稱, FileName--導出的文件路徑及文件名(原始數據庫格式)
'-------------------------------------------------------------------------------------------------------------
Public Function SaveKey(KeyRoot As EM_RegRootKey, KeyName As String, FileName As String) As Boolean
    On Error Resume Next
    
    Dim lpAttr As SECURITY_ATTRIBUTES                   ' 注冊表安全類型
    lpAttr.nLength = 50                                 ' 設置安全屬性為缺省值…
    lpAttr.lpSecurityDescriptor = 0                     ' …
    lpAttr.bInheritHandle = True                        ' …
    
    If EnablePrivilege(SE_BACKUP_NAME) = False Then
        SaveKey = False
        Exit Function
    End If
    
    Success = RegOpenKeyEx(KeyRoot, KeyName, 0&, KEY_ALL_ACCESS, hkey)
    If Success <> 0 Then
        SaveKey = False
        Success = RegCloseKey(hkey)
        Exit Function
    End If
    
    Success = RegSaveKey(hkey, FileName, lpAttr)
    If Success = 0 Then SaveKey = True Else SaveKey = False
    
    Success = RegCloseKey(hkey)
End Function

'-------------------------------------------------------------------------------------------------------------
'- 導入注冊表關鍵字的值
'- 參數說明: KeyRoot--根類型, KeyName--子項名稱, FileName--導入的文件路徑及文件名(原始數據庫格式)
'-------------------------------------------------------------------------------------------------------------
Public Function RestoreKey(KeyRoot As EM_RegRootKey, KeyName As String, FileName As String) As Boolean
    On Error Resume Next
    
    If EnablePrivilege(SE_RESTORE_NAME) = False Then
        RestoreKey = False
        Exit Function
    End If
    
    Success = RegOpenKeyEx(KeyRoot, KeyName, 0&, KEY_ALL_ACCESS, hkey)
    If Success <> 0 Then
        RestoreKey = False
        Success = RegCloseKey(hkey)
        Exit Function
    End If
    
    Success = RegRestoreKey(hkey, FileName, REG_FORCE_RESTORE)
    If Success = 0 Then RestoreKey = True Else RestoreKey = False
    
    Success = RegCloseKey(hkey)
End Function

'-------------------------------------------------------------------------------------------------------------
'- 使注冊表允許導入/導出
'-------------------------------------------------------------------------------------------------------------
Private Function EnablePrivilege(seName As String) As Boolean
    On Error Resume Next
    
    Dim p_lngRtn As Long
    Dim p_lngToken As Long
    Dim p_lngBufferLen As Long
    Dim p_typLUID As LUID
    Dim p_typTokenPriv As TOKEN_PRIVILEGES
    Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
    
    p_lngRtn = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, p_lngToken)
    If p_lngRtn = 0 Then
        EnablePrivilege = False
        Exit Function
    End If
    If Err.LastDllError <> 0 Then
        EnablePrivilege = False
        Exit Function
    End If
    
    p_lngRtn = LookupPrivilegeValue(0&, seName, p_typLUID)
    If p_lngRtn = 0 Then
      EnablePrivilege = False
      Exit Function
    End If
    
    p_typTokenPriv.PrivilegeCount = 1
    p_typTokenPriv.Privileges.Attributes = SE_PRIVILEGE_ENABLED
    p_typTokenPriv.Privileges.pLuid = p_typLUID
    
    EnablePrivilege = (AdjustTokenPrivileges(p_lngToken, False, p_typTokenPriv, Len(p_typPrevTokenPriv), p_typPrevTokenPriv, p_lngBufferLen) <> 0)
End Function

'-------------------------------------------------------------------------------------------------------------
'- 將 Double 型( 限制在 0--2^32-1 )的數字轉換為十六進制并在前面補零
'- 參數說明: Number--要轉換的 Double 型數字
'-------------------------------------------------------------------------------------------------------------
Private Function DoubleToHex(ByVal Number As Double) As String
    Dim strHex As String
    strHex = Space(8)
    For I = 1 To 8
        Select Case Number - Int(Number / 16) * 16
            Case 10
                Mid(strHex, 9 - I, 1) = "A"
            Case 11
                Mid(strHex, 9 - I, 1) = "B"
            Case 12
                Mid(strHex, 9 - I, 1) = "C"
            Case 13
                Mid(strHex, 9 - I, 1) = "D"
            Case 14
                Mid(strHex, 9 - I, 1) = "E"
            Case 15
                Mid(strHex, 9 - I, 1) = "F"
            Case Else
                Mid(strHex, 9 - I, 1) = CStr(Number - Int(Number / 16) * 16)
        End Select
        Number = Int(Number / 16)
    Next I
    DoubleToHex = strHex
End Function




Access軟件網官方交流QQ群 (群號:198348076)       access源碼網店

最新評論 查看更多評論(3)

2020/2/1 21:15:14崔宇
If CDbl(Value) <= 4294967295# And CDbl(Value) >= 0 Then

2018/1/24 13:10:54大海
If CDbl(Value) <= and="">= 0 Then這一句有問題

2018/1/8 22:15:29嫣然
厲害了

發表評論您的評論將提升作者分享的動力!快來評論一下吧!

用戶名:
密 碼:
內 容:
 

常見問答

技術分類

相關資源

關于我們 | 服務條款 | 在線投稿 | 友情鏈接 | 網站統計 | 網站幫助