clsregistry.cls

排队分诊管理系统源代码！该代码使用VB6开发环境

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

'APIs to open/close the registry
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 RegConnectRegistry Lib "advapi32.dll" _
        Alias "RegConnectRegistryA" _
        (ByVal lpMachineName As String, _
        ByVal hKey As Long, _
        phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
        (ByVal hKey As Long) As Long
        
'APIs to get/set values in the registry
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 RegQueryValueExString Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, _
        ByVal lpValueName As String, ByVal lpReserved As Long, _
        lpType As Long, lpData As String, _
        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 Long, ByVal cbData As Long) As Long
Private 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
Private Declare Function RegDeleteValue Lib "advapi32.dll" _
        Alias "RegDeleteValueA" _
        (ByVal hKey As Long, _
        ByVal lpValueName As String) As Long

'Enumerators
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 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
        
'APIs to create/remove keys
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

'Error codes
Private Const ERROR_SUCCESS = 0

'Registry constants
Public Enum REG_TYPE
    REG_BINARY = 3
    REG_CREATED_NEW_KEY = &H1
    REG_DWORD = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_DWORD_LITTLE_ENDIAN = 4
    REG_EXPAND_SZ = 2
    REG_FULL_RESOURCE_DESCRIPTOR = 9
    REG_LINK = 6
    REG_MULTI_SZ = 7
    REG_NONE = 0
    REG_NOTIFY_CHANGE_ATTRIBUTES = &H2
    REG_NOTIFY_CHANGE_LAST_SET = &H4
    REG_NOTIFY_CHANGE_NAME = &H1
    REG_NOTIFY_CHANGE_SECURITY = &H8
    REG_OPENED_EXISTING_KEY = &H2
    REG_OPTION_BACKUP_RESTORE = 4
    REG_OPTION_CREATE_LINK = 2
    REG_OPTION_NON_VOLATILE = 0
    REG_OPTION_RESERVED = 0
    REG_OPTION_VOLATILE = 1
    REG_REFRESH_HIVE = &H2
    REG_RESOURCE_LIST = 8
    REG_RESOURCE_REQUIREMENTS_LIST = 10
    REG_SZ = 1
    REG_WHOLE_HIVE_VOLATILE = &H1
    REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)
    REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)
End Enum
'Access constants
Private Const READ_CONTROL = &H20000
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

'FILETIME structure for use with RegEnumKeyEx
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

'This enum makes it easier then remembering constants
'It will help make the class function more like what
'the user is used to in RegEdit and RegEdt32.
Public Enum HKEYs
    eHKEY_CLASSES_ROOT = &H80000000
    eHKEY_CURRENT_USER = &H80000001
    eHKEY_LOCAL_MACHINE = &H80000002
    eHKEY_USERS = &H80000003
    eHKEY_PERFORMANCE_DATA = &H80000004
    eHKEY_CURRENT_CONFIG = &H80000005
    eHKEY_DYN_DATA = &H80000006
End Enum

Public Function CreateKey(PredefinedKey As HKEYs, KeyName As String) As Boolean
    Dim hNewKey As Long
    Dim rc As Long
    Dim se As SECURITY_ATTRIBUTES
    On Error GoTo handler
    
    'Make sure there is no backslash preceding the branch
    If Left$(KeyName, 1) = "\" Then
        KeyName = Right$(KeyName, Len(KeyName) - 1)
    End If

    'Create the branch
    se.lpSecurityDescriptor = 0
    se.bInheritHandle = False
    rc = RegCreateKeyEx(PredefinedKey, _
            KeyName, _
            0&, _
            vbNullString, _
            REG_OPTION_NON_VOLATILE, _
            KEY_ALL_ACCESS, _
            se, _
            hNewKey, _
            rc)
    
    If rc = ERROR_SUCCESS Then
    
        'Close the registry
        rc = RegCloseKey(hNewKey)
    
        'Return the result code
        CreateKey = True
    Else
        CreateKey = False
    End If
    
    'Bypass the error handler
    Exit Function

handler:
    CreateKey = False
End Function


Public Function DeleteKey(PredefinedKey As HKEYs, KeyName As String) As Boolean
    Dim rc As Long
    
    On Error GoTo handler
    
    'Make sure there is no backslash preceding the branch
    If Left$(KeyName, 1) = "\" Then
        KeyName = Right$(KeyName, Len(KeyName) - 1)
    End If

    'Call the API
    rc = RegDeleteKey(PredefinedKey, KeyName)
    If rc = ERROR_SUCCESS Then
        'Return result code
        DeleteKey = True
    Else
        DeleteKey = False
    End If
    
    'Bypass the error handler
    Exit Function

handler:
    DeleteKey = False
End Function

Public Function ListSubKey(PredefinedKey As HKEYs, KeyName As String, Index As Long) As String
    Dim rc As Long
    Dim hKey As Long
    Dim dwIndex As Long
    Dim lpName As String
    Dim lpcbName As Long
    Dim lpReserved As Long
    Dim lpftLastWriteTime As FILETIME
    Dim i As Integer
    
    On Error GoTo handler
    
    'Make sure there is no backslash preceding the branch
    If Left$(KeyName, 1) = "\" Then
        KeyName = Right$(KeyName, Len(KeyName) - 1)
    End If
    
    'Attempt to open the registry
    rc = RegOpenKeyEx(PredefinedKey, KeyName, _
            0, KEY_ALL_ACCESS, hKey)
            
    If rc = ERROR_SUCCESS Then
        'Allocate buffers for lpName
        lpcbName = 255: lpName = String$(lpcbName, Chr(0))
                    
        'Get the subkey
        rc = RegEnumKeyEx(hKey, Index, lpName, _
                lpcbName, lpReserved, vbNullString, _
                0, lpftLastWriteTime)
                
        If rc = ERROR_SUCCESS Then
            'Return the result
            ListSubKey = Left$(lpName, lpcbName)
        Else
            ListSubKey = ""
        End If
            
        'Close the registry
        RegCloseKey hKey
    End If
    
    'Bypass the error handler
    Exit Function

handler:
    ListSubKey = ""
End Function

Public Function SetValue(PredefinedKey As HKEYs, KeyName As String, ValueName As String, _
        Value As Variant, Optional ValueType As REG_TYPE = REG_SZ) As Boolean
    Dim rc As Long
    Dim hKey As Long
    Dim lpType As Long
    Dim lpcbData As Long
    Dim lpData As String
    
    On Error GoTo handler
    
    'Make sure there is no backslash preceding the branch
    If Left$(KeyName, 1) = "\" Then
        KeyName = Right$(KeyName, Len(KeyName) - 1)
    End If
    
    'Open the registry
    rc = RegOpenKeyEx(PredefinedKey, _
            KeyName, _
            0, _
            KEY_ALL_ACCESS, _
            hKey)

    If rc = ERROR_SUCCESS Then
        'Create a buffer so we can retrieve the data type of
        'the key. We'll need this to determine which API
        'we should call.
        lpcbData = 255
        lpData = String(lpcbData, Chr(0))
        
        'Get the value type first.
        'It will be returned via lpType argument
        rc = RegQueryValueEx(hKey, _
            ValueName, _
            0, lpType, _
            ByVal lpData, _
            lpcbData)
        
        If rc = ERROR_SUCCESS Then
            Select Case lpType
                Case REG_SZ
                    'Use a string data type
                    rc = RegSetValueExString(hKey, _
                        ValueName, _
                        0, _
                        REG_SZ, _
                        CStr(Value), _
                        Len(Value) + 1)
                Case REG_DWORD
                    'Use a DWORD data type
                    rc = RegSetValueEx(hKey, _
                        ValueName, _
                        0, _
                        REG_DWORD, _
                        CLng(Value), _
                        lpcbData)
            End Select
        Else
            rc = RegSetValueExString(hKey, _
                ValueName, _
                0, _
                ValueType, _
                CStr(Value), _
                Len(Value) + 1)
        End If
        
        'Close the registry
        RegCloseKey hKey
    End If
    
    'Return the result code
    SetValue = True
    
    'Bypass the error handler
    Exit Function

handler:
    SetValue = False
End Function

Public Function GetValue(PredefinedKey As HKEYs, ByVal KeyName As String, ByVal ValueName As String) As Variant
    Dim rc As Long
    Dim hKey As Long
    Dim lpData As String
    Dim lpDataDWORD As Long
    Dim lpcbData As Long
    Dim lpType As Long
    
    On Error GoTo handler
    
    'Make sure there is no backslash preceding the branch
    If Left$(KeyName, 1) = "\" Then
        KeyName = Right$(KeyName, Len(KeyName) - 1)
    End If
    
    'Attempt to open the registry
    rc = RegOpenKeyEx(PredefinedKey, KeyName, _
            0, KEY_ALL_ACCESS, hKey)
            
    If rc = ERROR_SUCCESS Then
        'Create a buffer so we can retrieve the data type of
        'the key. We'll need this to determine which API
        'we should call.
        lpcbData = 255
        lpData = String(lpcbData, Chr(0))
        
        'Get the value type first.
        'It will be returned via lpType argument
        rc = RegQueryValueEx(hKey, _
            ValueName, _
            0, lpType, _
            ByVal lpData, _
            lpcbData)
            
        If rc = ERROR_SUCCESS Then
            'Then read the value using the
            'appropriate data type...
            Select Case lpType
                Case REG_SZ
                    rc = RegQueryValueExString(hKey, _
                        ValueName, _
                        0, lpType, _
                        ByVal lpData, _
                        lpcbData)
                    
                    'Return the value
                    If rc = 0 Then
                        GetValue = Left$(lpData, lpcbData - 1)
                    Else
                        GetValue = ""
                    End If
                Case REG_DWORD
                    rc = RegQueryValueEx(hKey, _
                        ValueName, _
                        0, lpType, _
                        lpDataDWORD, _
                        lpcbData)
                    
                    'Return the value
                    If rc = 0 Then
                        GetValue = CLng(lpDataDWORD)
                    Else
                        GetValue = 0
                    End If
            End Select
        End If
        
        'Close the registry
        RegCloseKey hKey
    End If
    
    'Bypass the error handler
    Exit Function

handler:
    'Return a null value
    GetValue = Null
End Function