clsregistry.cls

小型医院管理

    If Not OpenRegOk Then Exit Function
    lReturn = RegDeleteValue(hKey, sValueName)
    If lReturn = 0 Then
        DeleteValue = True
    Else
        DeleteValue = False
    End If
End Function

    ' My Own Addition to this Class
    ' Works just like the GetSetting Function in VB
    ' By Brian Bender
Public Function GetSetting(hKey As HKeys, path As String, Value As Variant, DefaultValue As Variant) As Variant
    If Not OpenRegistry(hKey, path) Then
        'Path probably doesn't exsist. Return Default Value or uncomment to raise error
        'Err.Raise vbObjectError + 101, "Open Registry", "Could not open Registry"
        GetSetting = DefaultValue
        Exit Function
    End If
    Dim sReturn As Variant
    sReturn = GetValue(Value)
    CloseRegistry
    If IsEmpty(sReturn) Then sReturn = DefaultValue
    GetSetting = sReturn
End Function

    ' My Own Addition to this Class
    ' Works just like the SaveSetting Function in VB
    ' By Brian Bender
Public Function SaveSetting(hKey As HKeys, path As String, ValueName As Variant, Value As Variant, ValueType As lDataType) As Boolean
    If Not OpenRegistry(hKey, "") Then
        SaveSetting = False
        Exit Function
    End If
    'First create a Path regardless if it is there
    If Not CreateDirectory(path) Then
        SaveSetting = False
        CloseRegistry
        Exit Function
    End If
    'Second, get a new handle to that path
    If Not OpenRegistry(hKey, path) Then
        SaveSetting = False
        Exit Function
    End If
    'Third, Create the Value
    SaveSetting = CreateValue(ValueName, Value, ValueType)
    CloseRegistry
End Function

    ' This function will return a specific value from the registry
    ' eg.
    ' Dim MyString As String, 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
    ' MyString = MyReg.GetValue("Identifier")
    ' Debug.Print MyString
    ' MyReg.CloseRegistry

Function GetValue(ByVal VarName As String, Optional ReturnBinStr As Boolean = False) As Variant
    'on error goto handelgetavalue
    Dim i As Integer
    Dim SubKey_Value As String, TempStr As String, ReturnArray() As Variant
    Dim length As Long
    'Dim value_type As Long
    Dim RtnVal As Long, value_Type As lDataType
    If Not OpenRegOk Then Exit Function
    'Read the size of the value value
    RtnVal = RegQueryValueEx(hKey, VarName, 0&, value_Type, ByVal 0&, length)
    Select Case RtnVal
        Case 0 'Ok so continue
        Case 2 'Not Found
            Exit Function
        Case 5 'Access Denied
            GetValue = "Access Denied"
            Exit Function
        Case Else 'What?
            GetValue = "RegQueryValueEx Returned : (" & RtnVal & ")"
            Exit Function
    End Select
    'declare the size of the value and read it
    SubKey_Value = Space$(length)
    RtnVal = RegQueryValueEx(hKey, VarName, 0&, value_Type, ByVal SubKey_Value, length)
    Select Case value_Type
        Case REG_NONE
            'Not defined
            SubKey_Value = "Not defined value_type=REG_NONE"
        Case REG_SZ 'A null-terminated String
            SubKey_Value = Left$(SubKey_Value, length - 1)
        Case REG_EXPAND_SZ
            'A null-terminated string that contains unexpanded references to
            'environment variables (for example, "%PATH%").
            'Use ExpandEnvironmentStrings to expand
            SubKey_Value = Left$(SubKey_Value, length - 1)
        Case REG_BINARY 'Binary data in any form.
            SubKey_Value = Left$(SubKey_Value, length)
            If Not ReturnBinStr Then
                TempStr = ""
                For i = 1 To Len(SubKey_Value)
                    TempStr = TempStr & Right$("00" & Trim$(Hex(Asc(Mid$(SubKey_Value, i, 1)))), 2) & " "
                Next i
                SubKey_Value = TempStr
            End If
        Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN 'A 32-bit number.
            SubKey_Value = Left$(SubKey_Value, length)
            If Not ReturnBinStr Then
                TempStr = ""
                For i = 1 To Len(SubKey_Value)
                    TempStr = TempStr & Right$("00" & Trim$(Hex(Asc(Mid$(SubKey_Value, i, 1)))), 2) & " "
                Next i
                SubKey_Value = TempStr
            End If
        Case REG_DWORD_BIG_ENDIAN
            'A 32-bit number in big-endian format.
            'In big-endian format, a multi-byte value is stored in memory from
            'the highest byte (the "big end") to the lowest byte. For example,
            'the value 0x12345678 is stored as (0x120x34 0x56 0x78) in big-endian format.
        Case REG_LINK
            'A Unicode symbolic link. Used internally; applications should not use this type.
            SubKey_Value = "Not defined value_type=REG_LINK"
        Case REG_MULTI_SZ
            'Array of null-terminated string
            SubKey_Value = Left$(SubKey_Value, length)
            i = 0
            While Len(SubKey_Value) > 0
            ReDim Preserve ReturnArray(i) As Variant
            ReturnArray(i) = Mid$(SubKey_Value, 1, InStr(1, SubKey_Value, Chr(0)) - 1)
            SubKey_Value = Mid$(SubKey_Value, InStr(1, SubKey_Value, Chr(0)) + 1)
            i = i + 1
            Wend
            GetValue = ReturnArray
    Exit Function
    Case REG_RESOURCE_LIST
    'Device driver resource list.

    SubKey_Value = "Not defined value_type=REG_RESOURCE_LIST"
        Case REG_FULL_RESOURCE_DESCRIPTOR
        'Device driver resource list.
    SubKey_Value = "Not defined value_type=REG_FULL_RESOURCE_DESCRIPTOR"
        Case REG_RESOURCE_REQUIREMENTS_LIST
        'Device driver resource list.
    SubKey_Value = "Not defined value_type=REG_RESOURCE_REQUIREMENTS_LIST"
        Case Else
    SubKey_Value = "value_type=" & value_Type
    End Select
    GetValue = SubKey_Value
    Exit Function
handelgetavalue:
    GetValue = ""
    Exit Function
End Function

'This property returns the current KeyValue

Public Property Get RegistryRootKey() As HKeys
    RegistryRootKey = RootHKey
End Property

'This property returns the current 'Registry Directory' your in

Public Property Get SubDirectory() As String
    SubDirectory = SubDir
End Property

    ' This function open's the registry at a specific 'Registry Directory'
    ' eg.
    ' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer
    ' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, "") 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

Public Function OpenRegistry(ByVal RtHKey As HKeys, ByVal SbDr As String) As Integer
    'on error goto OpenReg
    Dim ReturnVal As Integer
    If RtHKey = 0 Then
        OpenRegistry = False
        OpenRegOk = False
        Exit Function
    End If
    RootHKey = RtHKey
    SubDir = SbDr
    If OpenRegOk Then
        CloseRegistry
        OpenRegOk = False
    End If
    ReturnVal = RegOpenKeyEx(RootHKey, SubDir, 0&, KEY_READ_WRITE, hKey)
    If ReturnVal <> 0 Then
        OpenRegistry = False
        Exit Function
    End If
    OpenRegOk = True
    OpenRegistry = True
    Exit Function
OpenReg:
    OpenRegOk = False
    OpenRegistry = False
    Exit Function
End Function

Public Function OneBackOnKey()
    SubDir = Mid$(SubDir, 1, FindLastBackSlash(SubDir) - 1)
    CloseRegistry
    OpenRegistry RootHKey, SubDir
End Function

'This function should be called after you're done with the registry
'eg. (see other examples)

Public Function CloseRegistry() As Boolean
    On Error Resume Next
    If RegCloseKey(hKey) <> 0 Then
        CloseRegistry = False
        Exit Function
    End If
    CloseRegistry = True
    OpenRegOk = False
End Function

Private Sub Class_Initialize()
    RootHKey = &H0
SubDir = ""
    hKey = 0
    OpenRegOk = False
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    If RegCloseKey(hKey) <> 0 Then
        Exit Sub
    End If
End Sub

Public Function SortArrayAscending(ValueList As Variant) As Variant
    'on error goto handelsort
    Dim RipVal As Variant
    Dim RipOrdinal As Long
    Dim RipDescent As Long
    Dim PrivateBuffer As Variant
    Dim Placed As Boolean
    Dim x As Long
    Dim y As Long
    If IsArray(ValueList) Then
        PrivateBuffer = ValueList
        'Ok, we start at the second position in the array and go from there
        RipOrdinal = 1
        RipDescent = 1
        For y = 1 To UBound(PrivateBuffer)
            RipVal = PrivateBuffer(y)
            If y <> 1 Then RipDescent = y
            Do Until Placed
                If PrivateBuffer(RipDescent - 1) >= RipVal Then
                    RipDescent = RipDescent - 1
                    If RipDescent = 0 Then
                        For x = y To RipDescent Step -1
                            If x = 0 Then Exit For
                            PrivateBuffer(x) = PrivateBuffer(x - 1)
                        Next x
                        PrivateBuffer(RipDescent) = RipVal
                        Placed = True
                    End If
                Else
                    'shift the array to the right
                    For x = y To RipDescent Step -1
                        If x = 0 Then Exit For
                        PrivateBuffer(x) = PrivateBuffer(x - 1)
                    Next x
                    'insert the ripped value
                    PrivateBuffer(RipDescent) = RipVal
                    Placed = True
                End If
            Loop
            Placed = False
        Next y
        SortArrayAscending = PrivateBuffer
    Else
        SortArrayAscending = ValueList
    End If
    Exit Function
handelsort:
    SortArrayAscending = ValueList
    Exit Function
End Function

Private Function FindLastBackSlash(VarValue As Variant) As Integer
    Dim i As Integer, iRtn As Integer
    iRtn = 0
    For i = Len(VarValue) To 1 Step -1
        If Mid$(VarValue, i, 1) = "\" Then
            iRtn = i
            Exit For
        End If
    Next i
    FindLastBackSlash = iRtn
End Function