Keskustelu: Ohjelmointikysymykset: VB6: VB ja Windowssin rekisteri

Dim vValue As Variant

Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_ARENA_TRASHED = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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, ByRef lpcbName As Long, _
'        ByVal lpReserved As Long, ByVal lpClass As String, _
'        ByRef lpcbClass As Long) 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 Any, _
'        lpcbData As Long) As Long

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, ByVal lpSecurityAttributes _
        As Long, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias _
       "RegCreateKeyA" (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 RegQueryValueExString Lib "advapi32.dll" Alias _
        "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
        String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
        As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
        "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
        String, ByVal lpReserved As Long, lpType As Long, lpData As _
        Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
        "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
        String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
        As Long, lpcbData 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 _
        lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
        "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As _
        String, ByVal Reserved As Long, ByVal dwType As Long, lpValue _
        As Long, ByVal cbData As Long) As Long

Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String

    Select Case lType
        Case REG_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                         lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
                         lType, lValue, 4)
    End Select
End Function

Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    'Determine the size and type of data to be read.
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)

    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        'For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
                  sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch - 1)
            Else
                vValue = Empty
            End If
        'For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                  lValue, cch)
            If lrc = ERROR_NONE Then
                vValue = lValue
            End If
        Case Else
            'All other data types not supported.
            lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function

QueryValueExError:
    Resume QueryValueExExit
End Function

' QueryValue "TestKey\SubKey1", "StringValue"
Public Function QueryValue(sKeyName As String, sValueName As String) As String
    Dim lRetVal As Long         'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim vValue As Variant      'setting of queried value
    sKeyName = "Software\" & sKeyName

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_QUERY_VALUE, hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    RegCloseKey (hKey)
    QueryValue = vValue
End Function

Private Function CreateNewKey(sNewKeyName As String) As Boolean
    Dim hNewKey As Long    'Handle to the new key.
    Dim lRetVal As Long    'Result of the RegCreateKeyEx function.
    lRetVal = RegCreateKeyEx(HKEY_LOCAL_MACHINE, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function

Public Function SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long) As Boolean
    Dim lRetVal As Long    'Result of the SetValueEx function.
    Dim hKey As Long       'Handle of open key.
    Dim keyExists As Boolean
On Error GoTo errhandler:
    sKeyName = "Software\" & sKeyName
    'CheckForKey returns true if the path is there.
    keyExists = checkForKey(sKeyName)

   If keyExists = False Then
       'Create the key.
       CreateNewKey sKeyName
   End If

    'Open the specified key.
    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_SET_VALUE, hKey)
    lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
    RegCloseKey (hKey)
    SetKeyValue = True
    Exit Function
errhandler:
' Tee virheen käsittely
End Function

Private Function checkForKey(strKey As String) As Boolean
    Dim iRet As Long
    iRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKey, 0, KEY_QUERY_VALUE, hKey)

    If iRet = 0 Then
        checkForKey = True
        RegCloseKey (hKey)
    Else
        checkForKey = False
    End If
End Function