clsregistry.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 = "clsRegistry"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Registry API's to use
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 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 RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, cbName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData 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 RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpKeyName As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function ExpandEnvironmentStrings Lib "advapi32.dll" (lpSrc As String, lpDst As String, ByVal nSize As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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 RegSetValueEx Lib "advapi32" 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 Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Variant
    bInheritHandle As Long
    End Type
    'Enum's for the OpenRegistry function
Public Enum HKeys
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum
'Enum's for the DataTypes
Public Enum lDataType
    REG_NONE = 0
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_DWORD_LITTLE_ENDIAN = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_LINK = 6
    REG_MULTI_SZ = 7
    REG_RESOURCE_LIST = 8
    REG_FULL_RESOURCE_DESCRIPTOR = 9
    REG_RESOURCE_REQUIREMENTS_LIST = 10
End Enum

'Right's for the OpenRegistry
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = &H20009
Private Const KEY_WRITE = &H20006
Private Const KEY_READ_WRITE = (KEY_READ Or KEY_WRITE)
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))

Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

' Local var's to keep track of things happening
Dim RootHKey As HKeys
Dim SubDir As String
Dim hKey As Long
Dim OpenRegOk As Boolean

    ' This function will return a array of variant with all the subkey values
    ' eg.
    ' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "Software\Microsoft") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' MyVariant = MyReg.GetAllSubDirectories
    ' For i = LBound(MyVariant) To UBound(My Variant)
    ' Debug.Print MyVariant(i)
    ' Next i
    ' MyReg.CloseRegistry

Function GetAllSubDirectories() As Variant
    'on error goto handelgetdirvalues
    Dim SubKey_Num As Integer
    Dim SubKey_Name As String
    Dim length As Long
    Dim ReturnArray() As Variant

    If Not OpenRegOk Then Exit Function
    'Get the Dir List
    SubKey_Num = 0
    Do
        length = 256
        SubKey_Name = Space$(length)
        If RegEnumKey(hKey, SubKey_Num, SubKey_Name, length) <> 0 Then Exit Do
        SubKey_Name = Left$(SubKey_Name, InStr(SubKey_Name, Chr$(0)) - 1)
        ReDim Preserve ReturnArray(SubKey_Num) As Variant
        ReturnArray(SubKey_Num) = SubKey_Name
        SubKey_Num = SubKey_Num + 1
    Loop
    GetAllSubDirectories = ReturnArray
    Exit Function
handelgetdirvalues:
    GetAllSubDirectories = Null
    Exit Function
    End Function

    ' This function will return a true or false when it creates a key for you
    ' eg.
    ' Dim MyReg As New CReadWriteEasyReg
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "Software\Microsoft") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' if MyReg.CreateDirectory("TestDir") then
    ' Msgbox "Key created"
    ' else
    ' msgbox "Couldn't Create key"
    ' end if
    ' MyReg.CloseRegistry

Public Function CreateDirectory(ByVal sNewDirName As String) As Boolean
    Dim hNewKey As Long, lpdwDisposition As Long
    Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
    Dim lReturn As Long

    If Not OpenRegOk Then Exit Function
    lReturn = RegCreateKeyEx(hKey, sNewDirName, 0&, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpSecurityAttributes, hNewKey, lpdwDisposition)
    If lReturn = 0 Then
        CreateDirectory = True
    Else
        CreateDirectory = False
    End If
End Function

    'This function will return a true or false when it deletes a key for you
    'eg.
    ' Dim MyReg As New CReadWriteEasyReg
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "Software\Microsoft") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' if MyReg.DeleteDirectory("MyTestDir") then
    ' Msgbox "Key Deleted"
    ' else
    ' msgbox "Couldn't Delete key"
    ' end if
    ' MyReg.CloseRegistry

Public Function DeleteDirectory(ByVal sKeyName As String) As Boolean
    Dim lReturn As Long

    If Not OpenRegOk Then Exit Function
    lReturn = RegDeleteKey(hKey, sKeyName)
    If lReturn = 0 Then
        DeleteDirectory = True
    Else
        DeleteDirectory = False
    End If
End Function

    'This function will return a array of variant with all the value names in a key
    'eg.
    ' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "HardWare\Description\System\CentralProcessor\0") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' MyVariant = MyReg.GetAllValues
    ' For i = LBound(MyVariant) To UBound(My Variant)
    ' Debug.Print MyVariant(i)
    ' Next i
    ' MyReg.CloseRegistry

Function GetAllValues() As Variant
    'on error goto handelgetdirvalues
    Dim lpData As String, KeyType As Long
    Dim BufferLengh As Long, vname As String, vnamel As Long
    Dim ReturnArray() As Variant, Index As Integer

    If Not OpenRegOk Then Exit Function
    'Get the Values List
    Index = 0
    Do
        lpData = String(250, " ")
        BufferLengh = 240
        vname = String(250, " ")
        vnamel = 240
        If RegEnumValue(ByVal hKey, ByVal Index, vname, vnamel, 0, KeyType, lpData, BufferLengh) <> 0 Then
            Exit Do
        End If
        vname = Left$(vname, InStr(vname, Chr$(0)) - 1)
        ReDim Preserve ReturnArray(Index) As Variant
        ReturnArray(Index) = vname
        Index = Index + 1
    Loop
    GetAllValues = ReturnArray
    Exit Function
handelgetdirvalues:
    GetAllValues = Null
    Exit Function
End Function

    'This function will return a true or false when it creates a value for you
    'eg.
    ' Dim MyReg As New CReadWriteEasyReg
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "Software\Microsoft") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' if MyReg.CreateValue("ValName", "This is written as the value",REG_SZ) then
    ' Msgbox "Value created"
    ' else
    ' msgbox "Couldn't Create Value"
    ' end if
    ' MyReg.CloseRegistry

Public Function CreateValue(ByVal sValueName As String, ByVal vWriteThis As Variant, ldValueDataType As lDataType, Optional Multi_SZ_AddtlStrings As Variant) As Boolean
    Dim lpData As String 'The pointer To the value written to the Registry key's value
    Dim cbData As Long 'The size of the data written To the Registry key's value, including termination characters If applicable
    Dim lReturn As Long 'The Error value returned by the Registry Function
    Dim Str As Variant

    If Not OpenRegOk Then Exit Function
    Select Case ldValueDataType
        Case REG_SZ, REG_EXPAND_SZ
            lpData = vWriteThis & Chr(0)
            cbData = Len(lpData)
            lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)
            If lReturn = 0 Then
                CreateValue = True
            Else
                CreateValue = False
            End If
            Case REG_MULTI_SZ
            lpData = vWriteThis & Chr(0)
            If Not IsMissing(Multi_SZ_AddtlStrings) Then
                If IsArray(Multi_SZ_AddtlStrings) Then
                    For Each Str In Multi_SZ_AddtlStrings
                        If Str <> "" And Str <> Chr(0) And Not IsNull(Str) Then
                            lpData = lpData & Str & Chr(0)
                        End If
                    Next Str
                Else
                    If Multi_SZ_AddtlStrings <> "" And Multi_SZ_AddtlStrings <> Chr(0) And Not IsNull(Multi_SZ_AddtlStrings) Then
                        lpData = lpData & Multi_SZ_AddtlStrings & Chr(0)
                End If
            End If
        End If
        lpData = lpData & Chr(0)
        cbData = Len(lpData)
        lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)
        If lReturn = 0 Then
            CreateValue = True
        Else
            CreateValue = False
        End If
        Case REG_DWORD
        lpData = CLng(vWriteThis)
        cbData = 4
        lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)
        If lReturn = 0 Then
            CreateValue = True
        Else
            CreateValue = False
        End If
        Case Else
        MsgBox "Unable To process that Type of data."
        CreateValue = False
    End Select
End Function

    'This function will return a true or false when it deletes a value for you
    ' eg.
    ' Dim MyReg As New CReadWriteEasyReg
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "Software\Microsoft") Then
    ' MsgBox "Couldn't open the registry"
    ' Exit Sub
    ' End If
    ' if MyReg.DeleteValue("ValName") then
    ' Msgbox "Value Deleted"
    ' else
    ' msgbox "Couldn't Delete Value"
    ' end if
    ' MyReg.CloseRegistry

Public Function DeleteValue(ByVal sValueName As String) As Boolean
    Dim lReturn As Long