cregistry.cls

即时通讯

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CRegistry"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'''''''''''''''''''''''''''''''''''''
''  说明
''''''''''''''''''''''''''''''''''''
'用 CreateKey 创建关键字，或打开它
'用 DeleteKey 删除关键字, ( 相当于一个子目录)
'用 DeleteValue 删除指定关键字的值
'GetValue 用于得到关键字的值
'SetValue 用于设置关键字的值
'
'Registrykey 存贮主关键字
'SubKey 存储子关键字
'KeyValue 存储子关键字的值
'
''''''''''''''''''''''''''''''''''
'注: '注: 只能写入字符串
'''''''''''''''''''''''''''''''''''
' public properties
Dim ptRootKey As Long               'HKEY_CLASS_ROOT or KEY_CURRENT_USER ...
Dim ptRegistryKey    As String      '私有关键字名
Dim ptSubKey    As String           '私有子关键字名
Dim ptKeyValue    As String         '私有子关键字值
Dim ptStatus    As String           '私有状态
Private mvarBaseKey As String       '存储主关键字，即公司所在位置

'按文件类型定义,描述文档类. 及他们如何被运用和管理的
Const HKEY_CLASSES_ROOT = &H80000000

'当前用户的配置和优先级
Const HKEY_CURRENT_USER = &H80000001

'有关本机的物理硬件,软件,网络和安全性的信息
Const HKEY_LOCAL_MACHINE = &H80000002

'本机所有用户的列表,及其设置和优先级
Const HKEY_USERS = &H80000003

'本机显示器和打印机的配置信息
Const HKEY_CURRENT_CONFIG = &H80000005

'包括当前运行统计数字在内的动态数据
Const HKEY_DYN_DATA = &H80000006

Const REG_SZ = 1

'建立关键字
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 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 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 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 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

' registry error constants
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_REGISTRY_RECOVERED = 1014&
Const ERROR_REGISTRY_CORRUPT = 1015&
Const ERROR_REGISTRY_IO_FAILED = 1016&
Const ERROR_NOT_REGISTRY_FILE = 1017&
Const ERROR_KEY_DELETED = 1018&
Const ERROR_NO_LOG_SPACE = 1019&
Const ERROR_KEY_HAS_CHILEDREN = 1020&
Const ERROR_CHILD_MUST_BE_VOLATILE = 1021&
Const ERROR_RXACT_INVALID_STATE = 1369&

' private error codes
Const REGAGENT_NOKEY = -1002
Const REGAGENT_NOSUBKEY = -1003

Private Sub Class_Initialize()
    ptRootKey = HKEY_LOCAL_MACHINE  '默认是 HKEY_LOCAL_MACHINE
End Sub


Public Property Let RootKey(ByVal vRootKey As String)
Dim str As String
    str = UCase(Trim(vRootKey))
    Select Case str
        Case "HKEY_CLASSES_ROOT"
            ptRootKey = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_USER"
            ptRootKey = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE"
            ptRootKey = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS"
            ptRootKey = HKEY_USERS
        Case "HKEY_CURRENT_CONFIG"
            ptRootKey = HKEY_CURRENT_CONFIG
        Case "HKEY_DYN_DATA"
            ptRootKey = HKEY_DYN_DATA
    End Select
End Property

Public Property Get RootKey() As String
    Select Case ptRootKey
        Case HKEY_CLASSES_ROOT
            RootKey = "HKEY_CLASSES_ROOT"
        Case HKEY_CURRENT_USER
            RootKey = "HKEY_CURRENT_USER"
        Case HKEY_LOCAL_MACHINE
            RootKey = "HKEY_LOCAL_MACHINE"
        Case HKEY_USERS
            RootKey = "HKEY_USERS"
        Case HKEY_CURRENT_CONFIG
            RootKey = "HKEY_CURRENT_CONFIG"
        Case HKEY_DYN_DATA
            RootKey = "HKEY_DYN_DATA"
    End Select
End Property

Public Property Let BaseKey(ByVal vData As String)
    mvarBaseKey = vData
End Property

Public Property Get BaseKey() As String
    BaseKey = mvarBaseKey
End Property

Property Get RegistryKey() As String
   RegistryKey = ptRegistryKey
End Property

Property Let RegistryKey(tRegistryKey As String)
   ptRegistryKey = mvarBaseKey + "\" + tRegistryKey
End Property

Property Get KeyValue() As String
    KeyValue = ptKeyValue
End Property

Property Let KeyValue(tKeyValue As String)
    ptKeyValue = tKeyValue
End Property

Property Get Status() As Long
   Status = ptStatus
End Property

Property Get SubKey() As String
   SubKey = ptSubKey
End Property

Property Let SubKey(tSubKey As String)
   ptSubKey = tSubKey
End Property

Public Sub CreateKey(Optional test As String = "")
Dim lResult As Long
    ptStatus = 0   ' assume success
    If test <> "" Then
         ptRegistryKey = test
    End If
    'make sure all required properties have been set
    If Len(ptRegistryKey) = 0 Then
        ' the key property is not set, so flag an error
         ptStatus = REGAGENT_NOKEY
         Exit Sub
    End If
    ' make the call to create the key
    ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lResult)
End Sub

Public Sub DeleteKey()
Dim lKeyId   As Long

   ptStatus = 0  ' assume success
   ' make sure all required properties have been set
   If (Len(ptRegistryKey) = 0) Or (Len(ptSubKey) = 0) Then
   ' the key property is not set , so flag an error
   ' the sub key property is not set, so flag an error
      ptStatus = REGAGENT_NOKEY
      Exit Sub
   End If
   ' open the key by attemption to create it . if it already exists we get back an  ID
   ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
   If ptStatus = 0 Then                                           'change
   ' we get a key  ID  so we can delete th entry
      ptStatus = RegDeleteKey(lKeyId, ByVal ptSubKey)
   End If
End Sub

Public Function GetValue(Optional RegKey As String, Optional RegSubKey As String) As String
Dim lResult As Long
Dim lKeyId As Long
Dim tKeyValue As String
Dim lBufferSize As Long

   ptStatus = 0  ' assume success
   ' make sure all required properties have been set
   If RegKey <> "" Then
        RegistryKey = RegKey
   ElseIf Len(ptRegistryKey) = 0 Then
         ' the key property is not set , so flag an error
              ptStatus = REGAGENT_NOKEY
              Exit Function
   End If
   If RegSubKey <> "" Then
         SubKey = RegSubKey
   End If
   ' open the key by attemption to create it. if it already exists we get back As ID
   ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
   If ptStatus <> 0 Then                                ' Error
   ' call failed, can't open the key so exit
      Exit Function
   End If
   ' determine the size of the data in the registry entry
   '得到缓冲区大小
   ptStatus = RegQueryValueEx(lKeyId, ptSubKey, 0&, REG_SZ, 0&, lBufferSize)
   If lBufferSize < 2 Then
   ' no data value available
      ptKeyValue = Empty
      Exit Function
   End If
   ' allocate the needed space for the key data
   tKeyValue = String(lBufferSize + 1, " ")
   ' get the value of the registry entry                '注意上下两个API参数的不同
   '得到关键字值
   ptStatus = RegQueryValueEx(lKeyId, ptSubKey, 0&, REG_SZ, ByVal tKeyValue, lBufferSize)
   ' trim the null at the end of the returned value
   ptKeyValue = Left$(tKeyValue, lBufferSize - 1)
   GetValue = ptKeyValue
End Function

Public Sub SetValue(Optional tempSubKey As String = "", Optional tempKeyValue As String = "")
Dim lKeyId   As Long
   ptStatus = 0 ' assume success
   If tempSubKey <> "" Then
        ptSubKey = tempSubKey
    End If
    If tempKeyValue <> "" Then
        ptKeyValue = tempKeyValue
    End If

   If Len(ptSubKey) = 0 Then
   ' the sub key property is not set, so flag an error
     ptStatus = REGAGENT_NOSUBKEY
     Exit Sub
   End If
   ' open the key by attemption to create it. if it already exists we get back an ID
   ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
   If ptStatus <> 0 Then                            'change
      ' call failed, can't open the key so exit
      SubKey = REGAGENT_NOKEY
      Exit Sub
   End If
   If Len(ptKeyValue) = 0 Then
   ' no key value, so clear any existing entry
      ptStatus = RegSetValueEx(lKeyId, ptSubKey, 0&, REG_SZ, 0&, 0&)
   Else
   ' set the registry entry to the value
      ptStatus = RegSetValueEx(lKeyId, ptSubKey, 0&, REG_SZ, ByVal ptKeyValue, CLen(ptKeyValue) + 1)
   End If

End Sub

Public Sub DeleteValue()
Dim lKeyId   As Long
   ptStatus = 0 ' assume success
   ' make sure all required properties have been set
   If Len(ptRegistryKey) = 0 Then
   ' the key property is not set, so flag an error
      ptStatus = REGAGENT_NOKEY
      Exit Sub
   End If
   If Len(ptSubKey) = 0 Then
   ' the sub key property is not set, so flag an error
      ptStatus = REGAGENT_NOSUBKEY
      Exit Sub
   End If
   ' open the key by attempting to creat it. if it already exists we get back an ID
   ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
   If ptStatus = 0 Then
   ' we got a key  ID  so we can delete the value
      ptStatus = RegDeleteValue(lKeyId, ByVal ptSubKey)
   End If
End Sub

Public Function GetEnumKey(RegKey As String, ReturnKey() As String) As Long
''------------------------------------------------------------
' Name:
' Purpose: 枚举各主键值,并存放在数组ReturnKey()中.
'               返回包含的项目数,=0:表示没有值
' Parameters:
' Date: July,20 99' Time: 17:52
'------------------------------------------------------------
Dim lngI As Long
Dim strName As String * 20
Dim lKeyId As Long

RegistryKey = RegKey

ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
   If ptStatus <> 0 Then                                ' Error
   ' call failed, can't open the key so exit
      Exit Function
   End If
    ptStatus = 0
    lngI = 0
   
   Do While ptStatus = ERROR_SUCCESS

        ptStatus = RegEnumKey(ByVal lKeyId, ByVal lngI, ByVal strName, 20)
        If ptStatus = ERROR_SUCCESS Then
            ReDim Preserve ReturnKey(lngI)
            ReturnKey(lngI) = strName
            lngI = lngI + 1
        End If
    Loop
    
    GetEnumKey = lngI

End Function

Public Function GetEnumValue(RegKey As String, _
                                                strName() As String, _
                                                strValue() As String) As Long
'------------------------------------------------------------
' Name:
' Purpose: 枚举各项目的值. 名称存放在数组strName()
'               值存放在数组strValue(),
'               返回包含的项目数, =0:表示没有值
' Parameters:
' Date: July,20 99' Time: 17:52
'------------------------------------------------------------

Dim lngI As Long
Dim strTemp As String * 20
Dim lKeyId As Long
Dim bytTemp As Byte
Dim TempKeyID As Long

If RegKey <> "" Then
    RegistryKey = RegKey
End If

ptStatus = RegCreateKey(ptRootKey, ptRegistryKey, lKeyId)
TempKeyID = lKeyId
   If ptStatus <> 0 Then                                ' Error
   ' call failed, can't open the key so exit
      Exit Function
   End If
  
  ptStatus = 0
  lngI = 0
  
Do While ptStatus = ERROR_SUCCESS
        ptStatus = RegEnumValue(ByVal TempKeyID, ByVal lngI, ByVal strTemp, 20, 0&, 20, bytTemp, 20)
        'TempKeyID = lKeyId
        If ptStatus = ERROR_SUCCESS Then
        ReDim Preserve strName(lngI)
        strName(lngI) = strTemp
        lngI = lngI + 1
        End If
Loop
GetEnumValue = lngI

If lngI = 0 Then Exit Function '如果没有任何值,则退出
ReDim strValue(UBound(strName))

For lngI = 0 To UBound(strName)
    strValue(lngI) = GetValue(, strName(lngI))
Next lngI

End Function