Registry read write local ou distant avec gestion d'erreurs en utilisant les api de windows
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...
A utiliser pour écrire et lire la registry en VB.
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
- Registry read write local ou distant avec gestion d'erreurs en utilisant les api de windows
- Application de gestion de rendez-vous - Forum VB.NET
- Logiciel de gestion salle de sport - Forum VB.NET
- Coder en c sur windows - Conseils pratiques -C / C++ / C++.NET
- Gestion des demandes d'intervention - Forum PHP
- Gestion pointage personnel - Forum PHP
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.