regedit.bas

能用的网吧计费管理系统(客户端).zip

Attribute VB_Name = "Regedit"
'VB提供了四个访问Windows注册表的函数，但是只能访问
'“HKEY_CURRENT_USER\Software\VB and VBA Program Settings”下,
'不能任意的访问，也不能存取除字符串以外类型的字段，幸好VB能通
'过于Windows API来访问注册表，于是笔者根据API函数编
'写这个访问注册表的模块，希望能对你有帮助。
'函数声明
Public Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String, phkResult As Long) As Long

Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Public Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String, phkResult As Long) As Long

Public Declare Function RegQueryValue Lib "advapi32.dll" _
Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey _
As String, ByVal lpValue As String, lpcbValue 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, lpType As Long, _
lpData As Any, lpcbData As Long) As Long

Public 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 Any, _
lpcbData As Long) As Long
'注意：原来的API浏览器中lpData原来的类型是Byte ，由于这个类型只支持
'Byte类型，所以改为Any类型才可正常读出数据

Public Declare Function RegDeleteValue Lib "advapi32.dll" _
Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _
lpValueName As String) As Long

Public 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

Public 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

Public 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

Public Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String) As Long

Public Declare Function ExpandEnvironmentStrings Lib "kernel32" _
Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, _
ByVal lpDst As String, ByVal nSize As Long) As Long

Public Enum OpTypeString
  oString = 1 '字符串
  oExpandSZ = 2 '展开式字符串
  oLongData = 7 '多重字符串
End Enum

Public Enum OpTypeNumber
  oLong = 4 '长整型
  oBinary = 3 'Binary数据
  oBigEndian = 5 'Big Endian长整数
End Enum

Public Enum OHKEY
 HKEY_CLASSES_ROOT = &H80000000
 HKEY_CURRENT_CONFIG = &H80000005
 HKEY_CURRENT_USER = &H80000001
 HKEY_DYN_DATA = &H80000006
 HKEY_LOCAL_MACHINE = &H80000002
 HKEY_USERS = &H80000003
End Enum



Public Function RegSaveStringValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As OpTypeString, hKeyValue As String) As Boolean
'写入字符串型数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, retk As Long, cbData As Long '声明变量
hKeyValue = hKeyValue + Chr(0)
RegSaveStringValue = False
cbData = LenB(StrConv(hKeyValue, vbFromUnicode)) '读取字符串的实际长度
ret = RegCreateKey(mhKey, lpSubKey, hKey) '如果人打开这个主键，没有则创建该主键
If ret = 0 Then
  If RegSetValueEx(hKey, hKeyName, 0, hValueType, ByVal hKeyValue, cbData) = 0 Then
   RegSaveStringValue = True '成功则返回真值
  End If
End If
RegCloseKey hKey '删除打开的键值，释放内存

End Function

Public Function RegSaveNumberValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As OpTypeNumber, hKeyValue As Long) As Boolean
'写入数字型数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, retk As Long, cbData As Long
cbData = 4 'Len(CStr(hKeyValue))
RegSaveNumberValue = False
ret = RegCreateKey(mhKey, lpSubKey, hKey)
If ret = 0 Then
  If RegSetValueEx(hKey, hKeyName, 0, hValueType, hKeyValue, cbData) = 0 Then
   RegSaveNumberValue = True
  End If
End If
RegCloseKey hKey '删除打开的键值，释放内存

End Function

Public Function RegReadValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As Long, hKeyValue As String) As Boolean
'读取数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, lenData As Long
ret = RegOpenKey(mhKey, lpSubKey, hKey)
If ret = 0 Then
 RegReadValue = True
 '读取数据类型
 ret = RegQueryValueEx(hKey, hKeyName, 0, hValueType, ByVal vbNullString, lenData)
  Select Case hValueType
   Case OpTypeString.oExpandSZ, OpTypeString.oLongData, OpTypeString.oString
    '如果是字符型
    Dim s As String, s2 As String
    s = String(lenData, Chr(0))
    RegQueryValueEx hKey, hKeyName, 0, hValueType, ByVal s, lenData
    Select Case hValueType
     Case OpTypeString.oString '如果是字符串
       hKeyValue = Left(s, InStr(s, Chr(0)) - 1)
     Case OpTypeString.oExpandSZ '如果是展开式字符串
      s2 = String(Len(s) + 256, Chr(0))
      ExpandEnvironmentStrings s, s2, Len(s2)
      hKeyValue = Left(s2, InStr(s2, Chr(0)) - 1)
     Case OpTypeString.oLongData '如果是多重字符串
      hKeyValue = Left(s, Len(s) - 1)
    End Select
   Case OpTypeNumber.oBigEndian, OpTypeNumber.oLong
    '如果是长整型
    Dim l As Long
    RegQueryValueEx hKey, hKeyName, 0, hValueType, l, lenData
    hKeyValue = CStr(l)
   Case OpTypeNumber.oBinary
    '如果是二进制型
    ReDim bArr(0 To lenData - 1) As Byte
        RegQueryValueEx hKey, hKeyName, 0, hValueType, bArr(0), lenData
        For i = 1 To lenData - 1
         hKeyValue = hKeyValue + Hex(bArr(i))
        Next i
  End Select
   
Else
  RegReadValue = False
End If
RegCloseKey hKey '删除打开的键值，释放内存

End Function

Public Function RegDeleteSubkey(hKey As OHKEY, SubKey As String)
'删除目录
'mhKey是指主键的名称，SubKey是指路径
    Dim ret As Long, Index As Long, hName 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 '如果删除失败则认为是NT则用递归方法删除目录
        Name = String(256, Chr(0))
        While RegEnumKey(hSubkey, 0, hName, Len(hName)) = 0 And _
              DeleteSubkeyTree(hSubkey, hName)
        Wend
        ret = RegDeleteKey(hSubkey, "")
    End If
    DeleteSubkeyTree = (ret = 0)
    RegCloseKey hSubkey '删除打开的键值，释放内存
End Function

Public Function RegDeleteKeyName(mhKey As OHKEY, SubKey As String, hKeyName As String) As Boolean
'删除子键数据
'mhKey是指主键的名称，SubKey是指路径，hKeyName是指键名
Dim hKey As Long, ret As Long
ret = RegOpenKey(mhKey, SubKey, hKey)
RegDeleteKeyName = False
If ret = 0 Then
  If RegDeleteValue(hKey, hKeyName) = 0 Then RegDeleteKeyName = True
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function

Public Function RegCountSubKey(mhKey As OHKEY, SubKey As String) As Long
'统计所有子键数目
'mhKey是指主键的名称，SubKey是指路径
Dim hKey As Long, ret As Long, idx As Long, lenName As Long, lpValeName As String, TypeData As Long, lenData As Long
idx = 0
ret = RegOpenKey(mhKey, SubKey, hKey)
If ret = 0 Then
 While RegEnumValue(hKey, idx, lpValeName, lenName, ByVal 0, TypeData, ByVal vbNullString, lenData) = 0
   idx = idx + 1
 Wend
End If
RegCountSubKey = idx
RegCloseKey hKey '删除打开的键值，释放内存
End Function

Public Function RegEnumSubKey(mhKey As OHKEY, SubKey As String, hKeyIndex As Long, hKeyName As String, hKeyType As Long, hKeyValue As String) As Boolean
'读取指定的子键键值
'mhKey是指主键的名称，SubKey是指路径，hKeyIndex是指定要返回第几个键名，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据

Dim hKey As Long, ret As Long, lenName As Long, lpValeName As String, TypeData As Long, lenData As Long
Dim s As String
s = String(lenData, Chr(0))
lenName = 256
lpValeName = String(256, Chr(0))
RegEnumSubKey = False
ret = RegOpenKey(mhKey, SubKey, hKey)
If ret = 0 Then
 If RegEnumValue(hKey, ByVal hKeyIndex, lpValeName, lenName, ByVal 0, TypeData, ByVal vbNullString, lenData) = 0 Then
  hKeyName = Left(lpValeName, InStr(lpValeName, Chr(0)) - 1) ' Left(s, InStr(s, Chr(0)) - 1)
  If RegReadValue(mhKey, SubKey, hKeyName, hKeyType, hKeyValue) Then
   RegEnumSubKey = True
  End If
 
 End If
End If
RegCloseKey hKey '删除打开的键值，释放内存

End Function