?? 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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -