registry.bas

多种图表的绘制及其运用

'
' Example 1   -   Read a string value from an .ini file.
'       Ex:   [ABC DEF GHI JKL]
'             AppName="My App"
'
'   sEntry = "AppName"
'   lResult = fReadIniFuzzy("C:\Windows\Myfile.ini", "DEF", sEntry, sValue)
'
'   Upon completion:
'       lResult  = 0
'       sSection = "ABC DEF GHI JKL"
'       sValue   = "My App"
'
Dim sNextChar    As String
Dim sLine        As String
Dim sEntry       As String
Dim sSectionName As String
Dim iLen         As Integer
Dim iLocOfEq     As Integer
Dim iFnum        As Integer
Dim bDone        As Boolean
Dim bFound       As Boolean
Dim bNewSection  As Boolean

On Error GoTo fReadIniFuzzyError
fReadIniFuzzy = 99
bDone = False
sValue = sDefault
sEntry = UCase$(sIniEntry)
sSection = UCase$(sSection)
iLen = Len(sSection)

iFnum = FreeFile
Open sIniFile For Input Access Read As iFnum

Line Input #iFnum, sLine
Do While Not EOF(iFnum) And Not bDone
    sLine = UCase$(Trim$(sLine))
    bNewSection = False
    '
    ' See if line is a section heading.
    '
    If Left$(sLine, 1) = "[" Then
        '
        ' See if section heading contains desired value.
        '
        sSectionName = sLine
        Dim iPos As Integer
        iPos = InStr(1, sLine, sSection)
        If iPos > 0 Then
            '
            ' Be sure the value is not part of a larger value.
            '
            sNextChar = Mid$(sLine, iPos + iLen, 1)
            If sNextChar = " " Or sNextChar = "]" Then
                '
                ' Search this section for the entry.
                '
                Line Input #iFnum, sLine
                bFound = False
                bNewSection = False
                Do While Not EOF(iFnum) And Not bFound
                    '
                    ' If we hit a new section, stop.
                    '
                    sLine = UCase$(Trim$(sLine))
                    If Left$(sLine, 1) = "[" Then
                        bNewSection = True
                        Exit Do
                    End If
                    '
                    ' Entry must start in column 1 to avoid comment lines.
                    '
                    If InStr(1, sLine, sEntry) = 1 Then
                        '
                        ' If entry found and line is not incomplete, get value.
                        '
                        iLocOfEq = InStr(1, sLine, "=")
                        If iLocOfEq <> 0 Then
                            sValue = Mid$(sLine, iLocOfEq + 1)
                            sSection = Mid$(sSectionName, 2, InStr(1, sSectionName, "]") - 2)
                            bFound = True
                            bDone = True
                            fReadIniFuzzy = 0
                        End If
                    End If
                    If Not bFound Then
                        Line Input #iFnum, sLine
                    End If
                Loop
                If EOF(iFnum) Then bDone = True
                sSection = Mid$(sSectionName, 2, InStr(1, sSectionName, "]") - 2)
            End If
        End If
    End If
    If Not bNewSection And Not bDone Then
        Line Input #iFnum, sLine
    End If
Loop
Close iFnum
Exit Function

fReadIniFuzzyError:
    MsgBox "Unable to read .ini file value.", vbExclamation, "fReadIniFuzzy"
    fReadIniFuzzy = 99
End Function
Public Function fReadValue(ByVal sTopKeyOrFile As String, ByVal sSubKeyOrSection As String, _
        ByVal sValueName As String, ByVal sValueType As String, ByVal vDefault As Variant, _
        vValue As Variant) As Long
'
' Use this function to:
'   -   Read a string or binary (True|False) registry value or
'   -   Read a string value from an .ini file.
'
' sTopKeyOrIniFile
'   -   A top level registry key abbreviation {"HKCU","HKLM","HKU","HKDD","HKCC","HKCR"} or
'   -   The full path of an .ini file (ex. "C:\Windows\MyFile.ini")
'
' sSubKeyOrSection
'   -   A registry subkey or
'   -   An .ini file section name
'
' sValueName
'   -   A registry entry or
'   -   An .ini file entry
'
' sValueType
'   -   "S" to read a string value or
'   -   "N" to read an integer value
'
' vDefault
'   -   The default value to return. It can be a string or boolean.
'
' vValue
'   -   The value read. It can be a string or boolean.
'   -   vDefault if unsuccessful (0 when reading an integer from an .ini file)
'
' Return Value
'   -   0 if successful, non-zero otherwise.
'
' Example 1   -   Read a string value from the registry.
'   lResult = fReadValue("HKCU", "Software\YourKey\LastKey\YourApp", "AppName", "S", "", sValue)
'
' Example 2   -   Read a boolean (True|False) value from the registry.
'   lResult = fReadValue("HKCU", "Software\YourKey\LastKey\YourApp", "AutoHide", "N", False, bValue)
'
' Example 3   -   Read a string value from an .ini file.
'   lResult = fReadValue("C:\Windows\Myfile.ini", "SectionName", "AppName", "S", "", sValue)
'
' Example 4   -   Read an integer value from an .ini file.
'   lResult = fReadValue("C:\Windows\Myfile.ini", "SectionName", "NumApps", "N", "0", iValue)
'
Dim lTopKey     As Long
Dim lHandle     As Long
Dim lLenData    As Long
Dim lResult     As Long
Dim lDefault    As Long
Dim sValue      As String
Dim sSubKeyPath As String
Dim sDefaultStr As String
Dim bValue      As Boolean

On Error GoTo fReadValueError
lResult = 99
vValue = vDefault
lTopKey = fTopKey(sTopKeyOrFile)
If lTopKey = 0 Then GoTo fReadValueError

If lTopKey = 1 Then
    '
    ' Read the .ini file value.
    '
    If UCase$(sValueType) = "S" Then
        lLenData = 255
        sDefaultStr = vDefault
        sValue = Space$(lLenData)
        lResult = GetPrivateProfileString(sSubKeyOrSection, sValueName, sDefaultStr, sValue, lLenData, sTopKeyOrFile)
        vValue = Left$(sValue, lResult)
    Else
        lDefault = 0
        lResult = GetPrivateProfileInt(sSubKeyOrSection, sValueName, lDefault, sTopKeyOrFile)
    End If
Else
    '
    ' Open the registry SubKey.
    '
    lResult = RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, KEY_QUERY_VALUE, lHandle)
    If lResult <> ERROR_SUCCESS Then GoTo fReadValueError
    '
    ' Get the actual value.
    '
    If UCase$(sValueType) = "S" Then
        '
        ' String value. The first query gets the string length. The second
        ' gets the string value.
        '
        lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, "", lLenData)
        If lResult = ERROR_MORE_DATA Then
            sValue = Space(lLenData)
            lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, ByVal sValue, lLenData)
        End If
        If lResult = ERROR_SUCCESS Then  'Remove null character.
            vValue = Left$(sValue, lLenData - 1)
        Else
            GoTo fReadValueError
        End If
    Else
        '
        ' Boolean value.
        '
        lLenData = Len(bValue)
        lResult = RegQueryValueEx(lHandle, sValueName, 0, 0, bValue, lLenData)
        If lResult = ERROR_SUCCESS Then
            vValue = bValue
        Else
            GoTo fReadValueError
        End If
    End If
    '
    ' Close the key.
    '
    lResult = RegCloseKey(lHandle)
    fReadValue = lResult
End If
Exit Function
'
' Error processing.
'
fReadValueError:
    ' 26mar99, no need in message box.
    'MsgBox "Unable to read registry or .ini file value.", vbExclamation, "fReadValue"
    fReadValue = lResult
End Function

Private Function fTopKey(ByVal sTopKeyOrFile As String) As Long
Dim sDir As String
'
' This function returns:
'   -   the numeric value of a top level registry key or
'   -   1 if sTopKey is a valid .ini file or
'   -   0 otherwise.
'
On Error GoTo fTopKeyError
fTopKey = 0
Select Case UCase$(sTopKeyOrFile)
    Case "HKCU"
        fTopKey = HKEY_CURRENT_USER
    Case "HKLM"
        fTopKey = HKEY_LOCAL_MACHINE
    Case "HKU"
        fTopKey = HKEY_USERS
    Case "HKDD"
        fTopKey = HKEY_DYN_DATA
    Case "HKCC"
        fTopKey = HKEY_CURRENT_CONFIG
    Case "HKCR"
        fTopKey = HKEY_CLASSES_ROOT
    Case Else
        On Error Resume Next
        sDir = Dir$(sTopKeyOrFile)
        If Err.Number = 0 And sDir <> "" Then fTopKey = 1
End Select
Exit Function

fTopKeyError:
    MsgBox "Unable to decode registry key or find .ini file.", vbExclamation, "fTopKey"
End Function

Public Function fWriteValue(ByVal sTopKeyOrFile As String, ByVal sSubKeyOrSection As String, _
        ByVal sValueName As String, ByVal sValueType As String, ByVal vValue As Variant) As Long
'
' Use this function to:
'   -   Write a string or binary (True|False) registry value or
'   -   Write a string value to an .ini file.
'
' sTopKeyOrIniFile
'   -   A top level registry key abbreviation {"HKCU","HKLM","HKU","HKDD","HKCC","HKCR"} or
'   -   The full path of an .ini file (ex. "C:\Windows\MyFile.ini")
'
' sSubKeyOrSection
'   -   A registry subkey or
'   -   An .ini file section name
'
' sValueName
'   -   A registry entry or
'   -   An .ini file entry
'
' sValueType
'   -   "S" to write a string value or
'   -   "N" to write a binary value (applies to registry use only)
'
' vValue
'   -   The value to write. It can be a string or boolean.
'
' Return Value
'   -   0 if successful, non-zero otherwise.
'
' Example 1   -   Write a string value to the registry.
'   lResult = fWriteValue("HKCU", "Software\YourKey\LastKey\YourApp", "AppName", "S", "MyApp")
'
' Example 2   -   Write a boolean (True|False) value to the registry.
'   lResult = fWriteValue("HKCU", "Software\YourKey\LastKey\YourApp", "AutoHide", "N", True)
'
' Example 3   -   Write a string value to an .ini file.
'   lResult = fWriteValue("C:\Windows\Myfile.ini", "SectionName", "AppName", "S", "MyApp")
'
' NOTE:
'   This function cannot write a non-string value to an .ini file.
'
Dim hKey                As Long
Dim lTopKey             As Long
Dim lOptions            As Long
Dim lsamDesired         As Long
Dim lHandle             As Long
Dim lDisposition        As Long
Dim lLenData            As Long
Dim lResult             As Long
Dim sClass              As String
Dim sValue              As String
Dim sSubKeyPath         As String
Dim bValue              As Boolean
Dim tSecurityAttributes As SECURITY_ATTRIBUTES

On Error GoTo fWriteValueError
lResult = 99
lTopKey = fTopKey(sTopKeyOrFile)
If lTopKey = 0 Then GoTo fWriteValueError

If lTopKey = 1 Then
    '
    ' Read the .ini file value.
    '
    If UCase$(sValueType) = "S" Then
        sValue = vValue
        lResult = WritePrivateProfileString(sSubKeyOrSection, sValueName, sValue, sTopKeyOrFile)
    Else
        GoTo fWriteValueError
    End If
Else
    sClass = ""
    lOptions = REG_OPTION_NON_VOLATILE
    lsamDesired = KEY_CREATE_SUB_KEY Or KEY_SET_VALUE
    '
    ' Create the SubKey or open it if it exists. Return its handle.
    ' lDisposition will be REG_CREATED_NEW_KEY if the key did not exist.
    '
    lResult = RegCreateKeyEx(lTopKey, sSubKeyOrSection, 0, sClass, lOptions, _
                  lsamDesired, tSecurityAttributes, lHandle, lDisposition)
    If lResult <> ERROR_SUCCESS Then GoTo fWriteValueError
    '
    ' Set the actual value.
    '
    If UCase$(sValueType) = "S" Then 'String value.
        sValue = vValue
        lLenData = Len(sValue) + 1
        lResult = RegSetValueEx(lHandle, sValueName, 0, REG_SZ, ByVal sValue, lLenData)
    Else   'Boolean value.
        bValue = vValue
        lLenData = Len(bValue)
        lResult = RegSetValueEx(lHandle, sValueName, 0, REG_BINARY, bValue, lLenData)
    End If
    '
    ' Close the key.
    '
    If lResult = ERROR_SUCCESS Then
        lResult = RegCloseKey(lHandle)
        fWriteValue = lResult
        Exit Function
    End If
End If
Exit Function
'
' Error processing.
'
fWriteValueError:
    MsgBox "Unable to write registry or .ini file value.", vbExclamation, "fWriteValue"
    fWriteValue = lResult
End Function


'21jun99, returns position of sFind.
' if not found returns 0.
Public Function myPos(sIn As String, sFind As String, Optional bRight As Boolean) As Integer
Dim i As Integer
    
    For i = Len(sIn) To 1 Step -1
        If Mid(sIn, i, 1) = sFind Then
            If bRight Then
                myPos = Len(sIn) - i + 1 ' counting from right.
            Else
                myPos = i
            End If
            Exit Function
        End If
    Next i
    
End Function