Registry read write local ou distant avec gestion d'erreurs en utilisant les api de windows

Soyez le premier à donner votre avis sur cette source.

Vue 6 409 fois - Téléchargée 616 fois

Description

Une classe pour lire et écrire la registry d'un ordi local ou distant, avec gestions d'erreurs.

La partie principale de ce programme est la classe

RegistryRW.cls

Qui est indépendante du projet et peut être utilisée dans d'autres projets.

(le UserControl n'est que le test de la classe)

Utilisation:
Dim regRW As RegistryRW
Set regRW = New RegistryRW
Dim val As String
'Computername can be "" for local machine or a name of a computer on the network
val = regRW.GetRegValue("Computername", HKEY_CURRENT_USER, "Test1\test2\haha", "KeyName")
if regRW.ErrNumber <> 0 then
MsgBox regRW.ErrDescription
End If
'etc...

Source / Exemple :


Option Explicit
'RegistryRW.cls
'24.05.2010 Philippe Hollmuller (philippe.hollmuller@gmail.com)
'Class for reading writing windows registry with error managment.
'You are free to use this class in your applications but not to sell the source code

'Use:
'Dim regRW As RegistryRW
'Set regRW = New RegistryRW
'Dim val As String
''Computername can be "" for local machine or a name of a computer on the network
'val = regRW.GetRegValue("Computername", HKEY_CURRENT_USER, "Test1\test2\haha", "KeyName")
'if regRW.ErrNumber <> 0 then
'    MsgBox regRW.ErrDescription
'End If

'Types Definition
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Public Enum RegKeyRootEnum
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_CURRENT_CONFIG = &H80000005
End Enum

Public Enum RegValTypeEnum
    REG_BINARY = 3
    REG_DWORD = 4 'A DWORD is a 32-bit unsigned integer (range: 0 through 4294967295 decimal). Because a DWORD is unsigned, its first bit (Most Significant Bit (MSB)) is not reserved for signing.
    REG_QWORD = 11 'A DWORD is a 64-bit unsigned integer (range: 0 through 18446744073709551615. Because a QWORD is unsigned, its first bit (Most Significant Bit (MSB)) is not reserved for signing.
    REG_SZ = 1
    REG_MULTI_SZ = 7
    REG_EXPAND_SZ = 2
End Enum

'API Declarations
'pour fermer la connection à la base de registre distante
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'pour se connecter à une base de regitre distante
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long
'pour lister les sous-clé d'une ruche
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
'pour lister les valeurs ruche
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
'ouvre une clé pour savoir si elle est valide
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
   
'Constants Definition
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = (KEY_READ)
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_LINK = 6
Private Const REG_NONE = 0
Private Const REG_NOTIFY_CHANGE_ATTRIBUTES = &H2
Private Const REG_NOTIFY_CHANGE_LAST_SET = &H4
Private Const REG_NOTIFY_CHANGE_NAME = &H1
Private Const REG_NOTIFY_CHANGE_SECURITY = &H8
Private Const REG_OPTION_BACKUP_RESTORE = 4
Private Const REG_OPTION_CREATE_LINK = 2
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_OPTION_RESERVED = 0
Private Const REG_OPTION_VOLATILE = 1
Private Const REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)
Private Const REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)
Private Const BUFFER_SIZE As Long = 255
Private Const ERROR_NO_MORE_ITEMS = 259&

Private Const MILLION_1 As Double = 1000000 'To split big String numbers DWORD OR QWORD and make double buffering

'API call and Constants for transfomringt API error to string:
Private Declare Function FormatMessage Lib "kernel32" _
  Alias "FormatMessageA" _
  (ByVal dwFlags As Long, _
   lpSource As Long, _
   ByVal dwMessageId As Long, _
   ByVal dwLanguageId As Long, _
   ByVal lpBuffer As String, _
   ByVal nSize As Long, _
   Args As Any) As Long
Private Const MAX_PATH As Long = 260
Private Const LB_SETTABSTOPS As Long = &H192
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000

'Private attributes:
Private myErrNumber As Long
Private myErrDescription As String

'Properties
Public Property Get ErrNumber() As Long
    ErrNumber = myErrNumber
End Property 'ok 22.05.2010

Public Property Get ErrDescription() As String
    ErrDescription = myErrDescription
End Property 'ok 22.05.2010

'Functions
Public Function keyRootAsString(keyRoot As RegKeyRootEnum) As String
    Select Case keyRoot
        Case HKEY_CLASSES_ROOT
            keyRootAsString = "HKEY_CLASSES_ROOT"
        Case HKEY_CURRENT_CONFIG
            keyRootAsString = "HKEY_CURRENT_CONFIG"
        Case HKEY_CURRENT_USER
            keyRootAsString = "HKEY_CURRENT_USER"
        Case HKEY_LOCAL_MACHINE
            keyRootAsString = "HKEY_LOCAL_MACHINE"
        Case HKEY_USERS
            keyRootAsString = "HKEY_USERS"
        Case Else
            keyRootAsString = CStrNotNull(keyRoot)
    End Select
End Function 'ok 19.05.2010

Public Function keyRootFromString(keyRootStr As String) As RegKeyRootEnum
    Select Case Trim(keyRootStr)
        Case "HKEY_CLASSES_ROOT"
            keyRootFromString = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_CONFIG"
            keyRootFromString = HKEY_CURRENT_CONFIG
        Case "HKEY_CURRENT_USER"
            keyRootFromString = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE"
            keyRootFromString = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS"
            keyRootFromString = HKEY_USERS
        Case Else
            keyRootFromString = 0
    End Select
End Function 'ok 19.05.2010

Public Function valTypeAsString(valType As RegValTypeEnum) As String
    Select Case valType
        Case REG_BINARY
            valTypeAsString = "REG_BINARY"
        Case REG_DWORD
            valTypeAsString = "REG_DWORD"
        Case REG_QWORD
            valTypeAsString = "REG_QWORD"
        Case REG_SZ
            valTypeAsString = "REG_SZ"
        Case REG_MULTI_SZ
            valTypeAsString = "REG_MULTI_SZ"
        Case REG_EXPAND_SZ
            valTypeAsString = "REG_EXPAND_SZ"
        Case Else
            valTypeAsString = CStrNotNull(valType)
    End Select
End Function 'ok 23.05.2010

Public Function valTypeFromString(valTypeStr As String) As RegKeyRootEnum
    Select Case Trim(valTypeStr)
        Case "REG_BINARY"
            valTypeFromString = REG_BINARY
        Case "REG_DWORD"
            valTypeFromString = REG_DWORD
        Case "REG_QWORD"
            valTypeFromString = REG_QWORD
        Case "REG_SZ"
            valTypeFromString = REG_SZ
        Case "REG_MULTI_SZ"
            valTypeFromString = REG_MULTI_SZ
        Case "REG_EXPAND_SZ"
            valTypeFromString = REG_EXPAND_SZ
        Case Else
            valTypeFromString = 0
    End Select
End Function 'ok 19.05.2010

'private use to connect to a computer's registry, local computer if name is empty ""
Private Function connectRegistry(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                                 ByRef hKeyResult As Long, FunctionName As String, Path As String) As Boolean
    On Error Resume Next
    myErrNumber = 0
    myErrDescription = ""
    Dim rv As Long
    rv = 1
    rv = RegConnectRegistry(ComputerName, CLng(keyRoot), hKeyResult)
    'l'api renvoie 0 si la connexion a pu être établi (cela évite de faire un ping)
    If rv = 0 Then
        connectRegistry = True
    Else
        connectRegistry = False
        myErrNumber = rv
        myErrDescription = "RegistryRW." & FunctionName & ": connectRegistry \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv)
    End If
    
    If Err.Number <> 0 Then
        connectRegistry = False
        myErrNumber = Err.Number
        myErrDescription = "RegistryRW." & FunctionName & ": connectRegistry \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
    End If
End Function 'ok 19.05.2010

Private Function openKey(hKeyResult As Long, Path As String, hKeyTmp As Long, keyRoot As RegKeyRootEnum, _
                         ComputerName As String, FunctionName As String) As Boolean
    On Error Resume Next
    Dim rv As Long
    rv = 1
    rv = RegOpenKey(hKeyResult, Path, hKeyTmp)
    'l'api renvoie 0 si la connexion a pu être établi (cela évite de faire un ping)
    If rv = 0 Then
        openKey = True
    Else
        openKey = False
        myErrNumber = rv
        myErrDescription = "RegistryRW." & FunctionName & ": Registry OpenKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv)
    End If
    
    If Err.Number <> 0 Then
        openKey = False
        myErrNumber = Err.Number
        myErrDescription = "RegistryRW." & FunctionName & ": Registry OpenKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
    End If
End Function 'ok 19.05.2010

'Fonctions
'Delete e Registry Key with all his contained Values
Public Function DeleteRegistryKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                                  Path As String) As Boolean
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "DeleteRegistryKey", Path) Then
        
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "DeleteRegistryKey") Then
            On Error Resume Next
            RegCloseKey hKeyTmp 'close the key opened by openKey
            
            Dim rv As Long
            rv = RegDeleteKey(hKeyResult, Path)
            If rv = 0 Then
                DeleteRegistryKey = True
            Else
                DeleteRegistryKey = False
                myErrNumber = rv
                myErrDescription = "RegistryRW.DeleteRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv)
            End If
            
            If Err.Number <> 0 Then
                DeleteRegistryKey = False
                myErrNumber = Err.Number
                myErrDescription = "RegistryRW.DeleteRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
            End If
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 19.05.2010

'Delete a Value from the Registry
Public Function DeleteValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                            Path As String, ValueName As String) As Boolean
    'le lien avec l'ordi distant ce fait grâce au hKeyResult qui est un paramettre de résultat
    'hKeyResult est le dernier paramettre de RegConnectRegistry et le premier de RegOpenKey
    
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "DeleteValue", Path) Then
        
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "DeleteValue") Then
            On Error Resume Next
            Dim rv As Long
            rv = RegDeleteValue(hKeyTmp, ValueName)
            If rv = 0 Then
                DeleteValue = True
            Else
                DeleteValue = False
                myErrNumber = rv
                myErrDescription = "RegistryRW.DeleteValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv)
            End If
            
            If Err.Number <> 0 Then
                DeleteValue = False
                myErrNumber = Err.Number
                myErrDescription = "RegistryRW.DeleteValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description
            End If
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 19.05.2010

'Creates a New Registry Key
Public Function CreateRegistryKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                                  Path As String) As Boolean
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "CreateRegistryKey", Path) Then
        On Error Resume Next
        Dim hKeyTmp As Long
        Dim y As SECURITY_ATTRIBUTES
        Dim Operation As Long
        Dim rv As Long
        rv = RegCreateKeyEx(hKeyResult, Path, 0, "", 0, KEY_ALL_ACCESS, y, hKeyTmp, Operation)
        If rv = 0 Then
            CreateRegistryKey = True
        Else
            CreateRegistryKey = False
            myErrNumber = rv
            myErrDescription = "RegistryRW.CreateRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv)
        End If
        
        If Err.Number <> 0 Then
            CreateRegistryKey = False
            myErrNumber = Err.Number
            myErrDescription = "RegistryRW.CreateRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
        End If
        
        RegCloseKey hKeyTmp 'close the key opened by RegCreateKeyEx
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 19.05.2010

'Get a specific Registry Value (to access the Default Registry Key Value set ValueName parameter as "")
Public Function GetRegValType(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                              Path As String, ValueName As String) As RegKeyRootEnum
    Dim rv As RegValTypeEnum
    GetRegValue ComputerName, keyRoot, Path, ValueName, rv
    GetRegValType = rv
End Function 'ok 23.05.2010

'Get a specific Registry Value (to access the Default Registry Key Value set ValueName parameter as "")
Public Function GetRegValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                            Path As String, ValueName As String, Optional ByRef valType As RegValTypeEnum = REG_SZ) As String
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "GetRegValue", Path) Then
        
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "GetRegValue") Then
            On Error Resume Next
            Dim keyValType As Long
            Dim KeyValSize As Long
            Dim KeyVal As String
            Dim tmpVal As String
            Dim i As Integer
            Dim rv As Long
            
            tmpVal = String(1024, 0)
            KeyValSize = 1024
            
            rv = RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize)
            If rv = 0 Then
                If KeyValSize > 0 Then
                    If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
                        tmpVal = Left(tmpVal, KeyValSize - 1)
                    Else
                        tmpVal = Left(tmpVal, KeyValSize)
                    End If
                Else
                    tmpVal = ""
                End If
                
                Select Case keyValType
                    Case REG_DWORD, REG_QWORD
                        Dim valMillionCount As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits
                        Dim valLow As Double          'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits
                        valLow = 0
                        For i = Len(tmpVal) To 1 Step -1
                            If valLow * 256 > 99999999# Then
                                Dim milc As Double
                                milc = Fix(valLow / MILLION_1)
                                valLow = valLow - (milc * MILLION_1)
                                valMillionCount = valMillionCount + milc
                            End If
                            valMillionCount = valMillionCount * 256
                            valLow = valLow * 256
                            valLow = valLow + Asc(Mid(tmpVal, i, 1))
                        Next i
                        
                        milc = Fix(valLow / MILLION_1)
                        valLow = valLow - (milc * MILLION_1)
                        valMillionCount = valMillionCount + milc
                                
                        Dim ErrMsg As String
                        'set KeyVal:
                        If Not DblToString(valLow, valMillionCount, KeyVal, ErrMsg) Then
                            myErrNumber = 1
                            myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: Error by transforming Values to string."
                        Else
                            valType = keyValType
                        End If
                    Case Else
                        KeyVal = tmpVal
                        valType = keyValType
                End Select
            Else
                KeyVal = ""
                myErrNumber = rv
                myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv)
            End If
            
            If Err.Number <> 0 Then
                KeyVal = ""
                myErrNumber = Err.Number
                myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description
            End If
            
            GetRegValue = KeyVal 'return value
            
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 22.05.2010

'Tests if a key exists by key path
Public Function ExistsKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                            Path As String) As Boolean
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "ExistsKey", Path) Then
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "ExistsKey") Then
            ExistsKey = True
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 24.05.2010

'Tests if a Value name exists in the key path
Public Function ExistsValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                            Path As String, ValueName As String) As Boolean
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "ExistsValue", Path) Then
        
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "ExistsValue") Then
            On Error Resume Next
            Dim keyValType As Long
            Dim KeyValSize As Long
            Dim tmpVal As String
            
            tmpVal = String(1024, 0)
            KeyValSize = 1024
            
            If RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize) = 0 Then
                ExistsValue = True
            End If
            
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 24.05.2010

'Create or Modify a Registry Value (to access the Default Registry Key Value set ValueName parameter as "")
Public Function SetRegValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                            Path As String, ValueName As String, NewValue As String, _
                            Optional ByVal RegValType As RegValTypeEnum = REG_SZ, _
                            Optional ByVal overwriteExixtingRegValType As Boolean = True) As Boolean
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "SetRegValue", Path) Then
        
        Dim hKeyTmp As Long
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "SetRegValue") Then
            On Error Resume Next
            Dim rv As Long
            Dim i As Integer
            Dim valMillionCount As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits
            Dim valLow As Double          'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits
            Dim keyValType As Long
            Dim KeyValSize As Long
            Dim oldRegValType As Long
            Dim tmpVal As String
            tmpVal = String(1024, 0)
            KeyValSize = 1024
            Dim existingVal As Boolean
            rv = RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize)
            oldRegValType = keyValType 'pour pouvoir récrire l'ancienne valeur en cas d'échec dépassement de capacité
            Select Case rv
                Case 0
                    existingVal = True
                Case 2
                    existingVal = False
                    keyValType = RegValType 'la valeur n'existe pas encore dans la registry
                Case Else 'Error
                    SetRegValue = False
                    myErrNumber = rv
                    myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv)
                    RegCloseKey hKeyTmp 'close the key opened by openKey
                    RegCloseKey hKeyResult 'close the key opened by connectRegistry
                    Exit Function       'EXIT
            End Select
            
            If keyValType <> RegValType Then 'Différence entre existante dans la registry et
                                             'voulue par la fonction
                If overwriteExixtingRegValType Then
                    keyValType = RegValType
                Else
                    SetRegValue = False
                    myErrNumber = rv
                    myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: RegistryValue allready existing with a different type."
                    RegCloseKey hKeyTmp 'close the key opened by openKey
                    RegCloseKey hKeyResult 'close the key opened by connectRegistry
                    Exit Function       'EXIT
                End If
            End If
            
            
            'Now do the writing depending on keyValType:
            
            Select Case keyValType
                Case REG_BINARY, REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
                    tmpVal = NewValue
                Case REG_DWORD, REG_QWORD
                    Dim oldVal As String  'lire Valeur existante, err et errDesc  pour pouvoir revenir en arrière en cas de dépassement de capacité.?
                    Dim oldErrDescription As String
                    Dim oldErrNr As Long
                    If existingVal Then
                        oldErrNr = ErrNumber
                        oldErrDescription = ErrDescription
                        oldVal = Me.GetRegValue(ComputerName, keyRoot, Path, ValueName) 'lire valeur avant d'écrire pour pouvoir revenir en arrière en cas de dépassement de capacité
                        If Me.ErrNumber <> 0 Then
                            existingVal = False
                        End If
                        myErrNumber = oldErrNr
                        myErrDescription = oldErrDescription
                    End If
                    
                    'préparation valeurs écriture
                    
                    Dim ErrMsg As String
                    If Not setDWordQWordValueFromString(NewValue, valLow, valMillionCount, ErrMsg) Then
                        SetRegValue = False
                        myErrNumber = 1
                        myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & NewValue & " is not " & IIf(keyValType = REG_DWORD, "DWORD", "QWORD") & ". " & ErrMsg
                        RegCloseKey hKeyTmp 'close the key opened by openKey
                        RegCloseKey hKeyResult 'close the key opened by connectRegistry
                        Exit Function       'EXIT
                    End If
                    tmpVal = ""
                    Dim loopLimit As Integer
                    If keyValType = REG_DWORD Then
                        loopLimit = 3
                    ElseIf keyValType = REG_QWORD Then
                        loopLimit = 7
                    End If
                    
                    'Construct the string for RegSetValueEx DWORD or QWORD
                    For i = 0 To loopLimit
                        valLow = valLow + ((valMillionCount - (Fix(valMillionCount / 256) * 256)) * MILLION_1)
                        valMillionCount = Fix(valMillionCount / 256)
                        tmpVal = tmpVal & Chr(valLow - (Fix(valLow / 256) * 256))
                        valLow = Fix(valLow / 256)
                    Next
                    If valLow > 0 Or valMillionCount > 0 Then
                        SetRegValue = False
                        myErrNumber = 1
                        myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & NewValue & " is not " & IIf(keyValType = REG_DWORD, "DWORD", "QWORD") & ", overflow." & ErrMsg
                        RegCloseKey hKeyTmp 'close the key opened by openKey
                        RegCloseKey hKeyResult 'close the key opened by connectRegistry
                        Exit Function       'EXIT
                    End If
                Case Else 'keyValType not implemented for write
                    SetRegValue = False
                    myErrNumber = 1
                    myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: keyValType " & CStr(keyValType) & " not implemented existing in registry. To be implemented in RegistryRW."
                    RegCloseKey hKeyTmp 'close the key opened by openKey
                    RegCloseKey hKeyResult 'close the key opened by connectRegistry
                    Exit Function 'EXIT
            End Select
            KeyValSize = Len(tmpVal)
            
            'Ecriture
            rv = RegSetValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize)
            If rv = 0 Then
                Select Case keyValType                      'Relecture pour contrôle
                    Case REG_DWORD, REG_QWORD
                                                            'dépassement de capacité, valeur écrite correspond à valeur voulue??
                        Dim valInRegEqualsWantedVal As Boolean
                        oldErrNr = ErrNumber
                        oldErrDescription = ErrDescription
                        Dim valLow1 As Double, valMillionCount1 As Double
                        Dim val1 As String
                        val1 = Me.GetRegValue(ComputerName, keyRoot, Path, ValueName) 'Lire la valeur écrite auparavant
                        If Me.ErrNumber <> 0 Then
                            SetRegValue = False
                            myErrDescription = "RegistryRW.SetRegValue read again: " & myErrDescription
                            RegCloseKey hKeyTmp 'close the key opened by openKey
                            RegCloseKey hKeyResult 'close the key opened by connectRegistry
                            Exit Function 'EXIT
                        End If
                        myErrNumber = oldErrNr
                        myErrDescription = oldErrDescription
                        
                        If setDWordQWordValueFromString(NewValue, valLow, valMillionCount, ErrMsg) Then
                            If setDWordQWordValueFromString(val1, valLow1, valMillionCount1, ErrMsg) Then
                                valInRegEqualsWantedVal = ((valLow = valLow1) And _
                                                           (valMillionCount = valMillionCount1))
                            End If
                        End If
                        
                        If valInRegEqualsWantedVal Then
                            SetRegValue = True
                        Else
                            SetRegValue = False
                            If existingVal Then 'remettre l'ancienne valeur
                                Me.SetRegValue ComputerName, keyRoot, Path, ValueName, oldVal, oldRegValType, overwriteExixtingRegValType
                            Else                'effacer la valeur faussement enregistrée
                                Me.DeleteValue ComputerName, keyRoot, Path, ValueName
                            End If
                            myErrNumber = 1
                            myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: overflow."
                            RegCloseKey hKeyTmp 'close the key opened by openKey
                            RegCloseKey hKeyResult 'close the key opened by connectRegistry
                            Exit Function 'EXIT
                        End If
                        
                    Case Else 'setting a string value, no control necessary
                        SetRegValue = True
                End Select
            Else
                SetRegValue = False
                myErrNumber = rv
                myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv)
            End If
            
            If Err.Number <> 0 Then
                SetRegValue = False
                myErrNumber = Err.Number
                myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description
            End If
                     
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
End Function 'ok 22.05.2010

'list the printers on a computer
Public Function listComputerPrinter(ComputerName As String) As Collection
    Set listComputerPrinter = listKeysIn(ComputerName, HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Printers")
End Function 'ok 19.05.2010

Public Function listKeysIn(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                           Path As String) As Collection
    Dim rv As Collection
    Set rv = New Collection
    
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "listKeysIn", Path) Then
        
        Dim hKeyTmp As Long, Cnt As Long, sName As String, ret As Long
        
        Cnt = 0
        ret = BUFFER_SIZE
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "listKeysIn") Then
            On Error Resume Next
    
            'crer un buffer
            sName = Space(BUFFER_SIZE)
    
            'énumaire les sous-clé
            While RegEnumKeyEx(hKeyTmp, Cnt, sName, ret, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_NO_MORE_ITEMS
    
                'ajoute les sous clés
                rv.Add (Left$(sName, ret))
    
                'prepare pour la clé suivante
                Cnt = Cnt + 1
                sName = Space(BUFFER_SIZE)
                ret = BUFFER_SIZE
    
            Wend
    
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
    
    Set listKeysIn = rv

    If Err.Number <> 0 Then
        myErrNumber = Err.Number
        myErrDescription = "RegistryRW.listKeysIn \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
    End If
End Function 'ok 22.05.2010

Public Function listValuesIn(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _
                             Path As String) As Collection
    Dim rv As Collection
    Set rv = New Collection
    
    Dim hKeyResult As Long
    If connectRegistry(ComputerName, keyRoot, hKeyResult, "listValuesIn", Path) Then
        
        Dim hKeyTmp As Long, Cnt As Long, sName As String, sData As String, ret As Long, RetData As Long
        
        Cnt = 0
        ret = BUFFER_SIZE
    
        Cnt = 0
        If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "listValuesIn") Then
            On Error Resume Next
            
            sName = Space(BUFFER_SIZE)
            sData = Space(BUFFER_SIZE)
            ret = BUFFER_SIZE
            RetData = BUFFER_SIZE
            
            'enumerate the values
            While RegEnumValue(hKeyTmp, Cnt, sName, ret, 0, ByVal 0&, ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS
                                                
                If ret > 0 Then
                    sName = Left$(sName, ret)
                Else
                    sName = ""
                End If
                If RetData > 1 Then
                    sData = Left$(sData, RetData - 1)
                Else
                    sData = ""
                End If
                
                If sName <> "" Then
                    rv.Add sName
                End If
                
                'prepare for next value
                Cnt = Cnt + 1
                sName = Space(BUFFER_SIZE)
                sData = Space(BUFFER_SIZE)
                ret = BUFFER_SIZE
                RetData = BUFFER_SIZE
            Wend
            'Close the registry key
            RegCloseKey hKeyTmp 'close the key opened by openKey
        End If
        RegCloseKey hKeyResult 'close the key opened by connectRegistry
    End If
    
    Set listValuesIn = rv

    If Err.Number <> 0 Then
        myErrNumber = Err.Number
        myErrDescription = "RegistryRW.listValuesIn \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description
    End If
End Function

'set les valeurs valLow et valMillionCount en fonction de la string d'entrée
Private Function setDWordQWordValueFromString(s As String, _
                                              valLow As Double, valMillionCount As Double, _
                                              ErrMsg As String) As Boolean
On Error Resume Next
    'Test si cast en Cdbl possible:
    Dim d As Double
    d = CDbl(Trim(s))
    If Err.Number <> 0 Then
        ErrMsg = Err.Description
        setDWordQWordValueFromString = False
        Exit Function 'EXIT ERROR
    End If
    If d < 0 Or Fix(d) <> d Then 'négatif ou contenand virgule
        ErrMsg = "Value < 0 is not a WORD, Word is unsigned value."
        setDWordQWordValueFromString = False
        Exit Function 'EXIT ERROR
    End If
    valLow = d  'd can be set from a big string like 1.2E+15
    valMillionCount = Fix(valLow / MILLION_1) 'split in buffers
    valLow = valLow - (valMillionCount * MILLION_1)
    
    setDWordQWordValueFromString = True
    'si pas d'erreur, valLow contient la valeur s sous forme de double, ok si 1.7E17,
    'mais arrondi en virgule flottante si grand nombre en string passé en paramètre
    'dépassant 15 caractères formattés pour calculs sur dbl
    'limite sans double buffering sans perdre de précision: 999999999999999
    
    'RECHERCHE DE PRECISION:
    'peut être que la string passée contient un grand nombre pour un QWord 64 bits, calculer
    If WordStrToLowAndHighDbl(Trim(s), valLow, valMillionCount) Then
        setDWordQWordValueFromString = True
    End If
    Err.Clear
End Function 'ok 22.05.2010

'Transformer un string en double
Private Function WordStrToLowAndHighDbl(s As String, valLow As Double, valMillionCount As Double) As Boolean
On Error Resume Next
    Dim v As Integer
    Dim i As Long
    
    Dim sLow As String, sMillionCount As String
    Dim numberMillion As Integer
    numberMillion = Len(CStr(MILLION_1)) - 1
    If Len(s) <= numberMillion Then
        sLow = s
    Else
        sLow = Right(s, numberMillion)
        sMillionCount = Left(s, Len(s) - Len(sLow))
    End If
    
    Dim sTmp As String
    Dim rv As Double
    Dim dLow As Double
    Dim dMillionCount As Double
    Dim lowIsSet As Boolean
    Dim MillionCountIsSet As Boolean
    
    'Calcule valLow:
    sTmp = sLow
    rv = 0
    For i = 1 To Len(sTmp)
        v = CInt(Mid(sTmp, i, 1)) 'can make error if 1.7E17 passed as parameter
        rv = 10 * rv
        rv = rv + CDbl(Mid(sTmp, i, 1))
        
        If Err.Number <> 0 Then
            Err.Clear
            Exit Function 'EXIT ERROR
        End If
    Next i
    If Len(sTmp) > 0 Then
        dLow = rv
        lowIsSet = True
    End If
    
    'Calcule valMillionCount:
    sTmp = sMillionCount
    rv = 0
    For i = 1 To Len(sTmp)
        v = CInt(Mid(sTmp, i, 1)) 'can make error if 1.7E17 passed as parameter
        rv = 10 * rv
        rv = rv + CDbl(Mid(sTmp, i, 1))
        
        If Err.Number <> 0 Then
            Err.Clear
            Exit Function 'EXIT ERROR
        End If
    Next i
    If Len(sTmp) > 0 Then
        dMillionCount = rv
        MillionCountIsSet = True
    End If
    
    If lowIsSet Then
        valLow = dLow
        
        If MillionCountIsSet Then
            valMillionCount = dMillionCount
        Else
            valMillionCount = 0
        End If
        
        WordStrToLowAndHighDbl = True
    End If
    Err.Clear
End Function  'ok 22.05.2010

'transforme deux doubles représentant un nombre en un string de sortie
Private Function DblToString(valLow, valMillionCount, _
                             ByRef StringToSet As String, ByRef ErrMsg As String) As Boolean
    On Error GoTo DblToString_Err
    Dim d As Double
    Dim deci As Double
    Dim rv As String
    
    d = valLow
    While d >= 1
        d = d / 10
        deci = d - Fix(d)
        d = Fix(d)
        rv = Left(CStr(Round(deci * 10)), 1) & rv
    Wend
    If valMillionCount > 0 Then
        Dim numberMillion As Integer
        numberMillion = Len(CStr(MILLION_1)) - 1
        While Len(rv) < numberMillion
            rv = "0" & rv
        Wend
    End If
    d = valMillionCount
    While d >= 1
        d = d / 10
        deci = d - Fix(d)
        d = Fix(d)
        rv = Left(CStr(Round(deci * 10)), 1) & rv
    Wend
    
    If rv = "" Then
        rv = 0
    End If
    
    StringToSet = rv
    DblToString = True
    Exit Function
    
DblToString_Err:
    StringToSet = ""
    ErrMsg = Err.Description
    DblToString = False
    Err.Clear
End Function  'ok 19.05.2010

Private Function CStrNotNull(val As Variant)
    CStrNotNull = ""
    On Error Resume Next
    CStrNotNull = CStr(val)
    If Err.Number <> 0 Then
        CStrNotNull = ""
    End If
End Function

'API error to string:
Public Function WinApiErrorAsString(msgID As Long) As String
   Dim ret As Long
   Dim sVal As String
   Dim sCodes As String
   Dim sBuff As String
   
   sBuff = Space$(MAX_PATH)
   ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                       FORMAT_MESSAGE_IGNORE_INSERTS Or _
                       FORMAT_MESSAGE_MAX_WIDTH_MASK, _
                       0&, msgID, 0&, _
                       sBuff, Len(sBuff), 0&)
   sBuff = Left$(sBuff, ret)
   'sCodes = msgID & vbTab & Hex(msgID) & vbTab
   
   If ret Then
      WinApiErrorAsString = sCodes & sBuff
   Else
      WinApiErrorAsString = sCodes & "(No such error)"
   End If
End Function

Conclusion :


A utiliser pour écrire et lire la registry en VB.

Codes Sources

A voir également

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.