Koodit: VB6: Rekisterin käsittely

' Paluu arvo
Dim vValue As Variant

' Rekisteriavaimen tietotyyppi
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4

' Avainpuun juuren konstantit
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003

' Virhe konstantit - vain muutama käytössä.
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

' Sulkee avatun rekisteriavaimen
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

' Luo uuden rekisteriavaimen
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

' Avaa olemassaolevan rekisteriavaimen
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

' Lukee string-tyyppisen arvon avaimesta
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

' Lukee long-tyyppisen arvon avaimesta
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

' Käytetään tutkimaan onko arvo luettavan tyyppinen
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

' Kirjoittaa string-tyyppisen arvon avaimeen
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

' Kirjoittaa long-tyyppisen arvon avaimeen
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

'***********************************************************************************
'   Metodi:     SetKeyValue
'   Tarkoitus:  Julkinen rajapinta-funktio rekisteriarvon kirjoittamiselle / päivittämiselle
'   Kuvaus:     Luo uuden rekisteriavaimen/Päivittää rekisteriavaimen arvon
'   Käyttö:     strKeyValue=QueryValue("MySoftware/MySubKey","MyKey","MyValue")
'   Paluuarvo:  String
'***********************************************************************************
Public Function SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long) As Boolean
    Dim lRetVal As Long         ' Tulos SetValueEx-funktiosta.
    Dim hKey As Long            ' Hanska avattavalle avaimelle.
    Dim keyExists As Boolean    ' Onko avain olemassa vai pitääkö se luoda?

On Error GoTo ErrHandler:
    ' Lisätty "pakote" avaimen lukemisesta tiettystä hakemistosta.
    ' Voidaan kommentoida pois tarvittaessa
    sKeyName = "Software\" & sKeyName

    'CheckForKey palauttaa true jos polku löytyy
    keyExists = CheckForKey(sKeyName)

    ' Jos avainta ei löydy...
   If keyExists = False Then
       '...luodaan uusi avain
       CreateNewKey sKeyName
   End If

    'Avain löytyy - siispä avataan se
    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_SET_VALUE, hKey)
    ' Kirjoitetaan arvo
    lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
    ' Suljetaan avain
    RegCloseKey (hKey)
    ' Palautetaan true onnistumisen merkiksi
    SetKeyValue = True
    Exit Function
ErrHandler:
    ' Palautetaan false, koska jotain meni pieleen
    SetKeyValue = False
End Function

'***************************************************************************************
'   Metodi:         QueryValue
'   Tarkoitus:      Julkinen rajapinta-funktio rekisteriarvon lukemiselle
'   Kuvaus:         Lukee rekisteristä parametrinä
'                   annetun rekisteriavaimen arvon
'   Käyttö:         strKeyValue=QueryValue("MySoftware/MySubKey","MyKey")
'   Parametrit:     sKeyName    -   Avaimen hakemistopolku muotoa:"AvainHakemisto
'                                   /AvainAliHakemisto/AvainAliHakemisto"
'                   sValueName  -   Avaimen nimi muotoa:"OmaAvain"
'   Paluuarvo:      String
'   Huomioitavaa:   Käsittelee avaimia vain HKEY_LOCAL_MACHINE - pääavaimen alla.
'                   Jos halutaan muutettavaksi muualle käytetaan seuraavia konstantteja:
'                   HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
'***************************************************************************************
Public Function QueryValue(sKeyName As String, sValueName As String) As String
    Dim lRetVal As Long         ' API-funktion paluuarvo
    Dim hKey As Long            ' Avattavan avaimen hanska
    Dim vValue As Variant       ' Luettu paluuarvo
On Error GoTo ErrHandler

    ' Lisätty "pakote" avaimen sijoittamiseksi tiettyyn hakemistoon.
    ' Voidaan kommentoida pois tarvittaessa
    sKeyName = "Software\" & sKeyName
    ' Avataan rekisteriavain
    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_QUERY_VALUE, hKey)
    ' Luetaan arvo
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    ' Suljetaan avain
    RegCloseKey (hKey)
    ' Asetetaan paluuarvo
    QueryValue = vValue
    Exit Function
ErrHandler:
    ' Palautetaan null koska arvoa ei voitu lukea
    ' Tähän muun tyyppinen virheen käsittely tarvittaessa
    QueryValue = vbNullString
End Function
'***************************************************************************************
'   Metodi:         SetValueEx
'   Tarkoitus:      Sisäinen funktio rekisteriarvon kirjoittamiseksi tyyppikohtaisesti
'   Kuvaus:         Tutkii kirjoitettavan arvon tyypin ja kutsuu sen
'                   perusteella tyyppiä vastaavaa API-kutsua.
'***************************************************************************************
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
        ' Kirjoita string
        Case REG_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                         lType, sValue, Len(sValue))
        ' Kirjoita Long
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
                         lType, lValue, 4)
    End Select
End Function
'***************************************************************************************
'   Metodi:         QueryValueEx
'   Tarkoitus:      Sisäinen funktio rekisteriarvon lukemiseksi tyyppikohtaisesti
'   Kuvaus:         Tutkii luettavan arvon tyypin ja palauttaa sen variantissa.
'***************************************************************************************
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

    'Päättele luettavan datan tyyppi
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)

    ' Jos virheitä syntyy - poistu
    If lrc <> ERROR_NONE Then Error 5

    ' Lue tyypin perusteella rekisteriarvo
    Select Case lType
        'String
        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
        'DWORDS - eli long
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                  lValue, cch)
            If lrc = ERROR_NONE Then
                vValue = lValue
            End If
        Case Else
            'Muita datatyyppejä ei tueta!
            lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function

QueryValueExError:
    Resume QueryValueExExit
End Function
'***************************************************************************************
'   Metodi:         CreateNewKey
'   Tarkoitus:      Sisäinen funktio rekisteriavaimen luomiseksi
'***************************************************************************************
Private Function CreateNewKey(sNewKeyName As String) As Boolean
    Dim hNewKey As Long    ' Hanska uuteen avaimeen
    Dim lRetVal As Long    ' RegCreateKeyEx funktion tulos
    ' Kutsu API-funktiota
    lRetVal = RegCreateKeyEx(HKEY_LOCAL_MACHINE, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    ' Sulje luotu avain - se avataan uudelleen myöhemmin
    RegCloseKey (hNewKey)
End Function
'***************************************************************************************
'   Metodi:         CheckForKey
'   Tarkoitus:      Sisäinen funktio rekisteriavaimen olemassaolon tutkimiseksi
'***************************************************************************************
Private Function CheckForKey(strKey As String) As Boolean
    Dim iRet As Long
    '  Yritä avata avain
    iRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, strKey, 0, KEY_QUERY_VALUE, hKey)
    ' Tutkitaan onnistuiko avaaminen
    If iRet = 0 Then
        ' Onnistui
        CheckForKey = True
        ' Suljetaan avain
        RegCloseKey (hKey)
    Else
        ' Epäonnistui
        CheckForKey = False
    End If
End Function