Je partage mon module qui me permet de manipuler le registre avec assez de facilité.
Le principe de lecture ou d'écriture est haché donc plus besoin de se préoccuper du type de la donnée.
Vous pouvez le tester, le changer, l'améliorer a votre guise !
Par exemple, une fonction de suppression :)
Pour les explications:
GetStringRegisterError - Fonction qui récupère un message d'erreur pré formaté
ClearRegister - Vide les informations d'accès registre temporaires
CloseRegister - Ferme l'accès au registre
SetSubRoot - Change le chemin clé après utilisation de SetRoot
SetRoot - Ouvre un chemin clé
OpenRegister - Ouvre l'accès au registre
CheckRoot - Routine qui contrôle si le chemin clé existe
CreateSubKey - Création d'une sous-clé
CreateKey - Création d'un chemin clé
SetValue - Modifie ou écrit une valeur de sous-clé
GetValue - Lecture d'une valeur de sous-clé
DIRECT_QueryValueEx - Lecture direct sans utiliser OpenRegister / CloseRegister
Source / Exemple :
Public Enum enREG_KEYS
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
Enum enREG_TYPES
REG_NONE = 0 ' No value type
REG_SZ = 1 ' Unicode nul terminated string
REG_EXPAND_SZ = 2 ' Unicode nul terminated string
REG_BINARY = 3 ' Free form binary
REG_BINARY_HEX = 8 ' Free form binary hex
REG_BINARY_LONG = 9 ' Free form binary lng
REG_DWORD = 4 ' 32-bit number
REG_DWORD_BIG_ENDIAN = REG_DWORD
REG_LINK = 6 ' Symbolic Link (unicode)
REG_MULTI_SZ = 7 ' Multiple Unicode strings
End Enum
Private Type tyRegister
hKey As Long 'Handle clé registre depuis constante
hSKey As Long 'Handle de retour apres ouverture registre
SubKey As String 'Chaine de la sous clé
TypeKey As Long 'Type de donnée écrire ou lue
HaveError As Boolean 'Erreur dans la fonction executé
HaveErrorDescription As String 'Description de l'erreur
End Type
Public MyRegister As tyRegister
Const KEY_READ = &H20019
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (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 RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, 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, lpData As Any, ByVal cbData As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Public Function DIRECT_QueryValueEx(ByRef myKey As enREG_KEYS, ByRef mySubKey As String, ByRef myValueKey As String) As Variant
Dim lResult As Long, lRtData As Long
Dim lRtType As enREG_TYPES
Call OpenRegister(myKey, mySubKey)
lResult = RegQueryValueEx(MyRegister.phKey, myValueKey, 0, lRtType, ByVal 0, lRtData)
TypeKey = lRtType
'0 = Success de lecture de la valeur
If lResult = 0 Then
DIRECT_QueryValueEx = True
Else
DIRECT_QueryValueEx = False
End If
DIRECT_QueryValueEx = GetStringRegisterError("ERROR", "DIRECT_QueryValueEx", 0, lRt)
Call CloseRegister
End Function
Public Function GetValue(ByVal sKeyValue As String) As Variant
Dim lResult As Long, sDataBuf() As Byte, lDataBufSize As Long
Dim lRtType As enREG_TYPES
Dim rtString As String
Dim rtLong As Long
lResult = RegQueryValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, ByVal 0, lDataBufSize)
TypeKey = lRtType
If lResult = 0 Then
ReDim sDataBuf(0 To lDataBufSize) As Byte
lResult = RegQueryValueEx(MyRegister.hSKey, sKeyValue, 0, 0, sDataBuf(0), lDataBufSize)
Select Case lRtType
Case REG_SZ, REG_EXPAND_SZ
rtString = Space$(lDataBufSize - 1)
CopyMemory ByVal rtString, sDataBuf(0), lDataBufSize - 1
GetValue = Trim(rtString)
Case REG_MULTI_SZ
rtString = Space$(lDataBufSize - 1)
CopyMemory ByVal rtString, sDataBuf(0), lDataBufSize - 1
GetValue = Replace(rtString, Chr(0), vbNewLine)
Case REG_DWORD
CopyMemory rtLong, sDataBuf(0), 4
GetValue = rtLong
Case REG_BINARY
If lDataBufSize <> UBound(sDataBuf) + 1 Then
ReDim Preserve sDataBuf(0 To lDataBufSize - 1) As Byte
End If
GetValue = sDataBuf()
End Select
End If
Call GetStringRegisterError("ERROR", "GETVALUE", 0, lResult)
End Function
Private Function GetStringToBytesNumber(sAny As String) As Long
Static i As Long
Dim j As Long
j = 0
For i = 1 To Len(sAny) Step 2
j = j + 1
Next i
GetStringToBytesNumber = j
End Function
Public Sub SetValue(ByVal lRtType As enREG_TYPES, sKeyValue As String, strData As Variant)
Dim lResult As Long
Dim lenTmp As Long
Dim sDataBuf() As Byte
Dim rtString As String
Dim rtLong As Long
Select Case lRtType
Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
rtString = CStr(strData)
lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, ByVal rtString, Len(rtString))
Case REG_BINARY
If IsNumeric(strData) = True Then
rtLong = CLng(strData)
Else
rtLong = CLng("&h" & strData)
End If
lenTmp = GetStringToBytesNumber(CStr(rtLong))
ReDim sDataBuf(lenTmp - 1) As Byte
CopyMemory sDataBuf(0), rtLong, lenTmp
lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, sDataBuf(0), lenTmp - 1)
Case REG_BINARY_HEX
lenTmp = GetStringToBytesNumber(CStr(strData))
ReDim sDataBuf(lenTmp - 1) As Byte
rtLong = "&h" & strData
CopyMemory sDataBuf(0), rtLong, lenTmp
lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, REG_BINARY, sDataBuf(0), lenTmp)
Case REG_BINARY_LONG
rtLong = strData
lenTmp = GetStringToBytesNumber(CStr(Hex(strData)))
lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, REG_BINARY, rtLong, lenTmp)
Case REG_DWORD
rtLong = CLng(strData)
lResult = RegSetValueEx(MyRegister.hSKey, sKeyValue, 0, lRtType, rtLong, 4)
End Select
Erase sDataBuf
Call GetStringRegisterError("ERROR", "SETVALUE", 0, lResult)
End Sub
Public Sub CreateKey(ByVal myNewSKey As String, Optional CreateAndRoot As Boolean = False)
Dim lResult As Long, rtKey As Long
If CheckRoot(myNewSKey) = True Then Exit Sub
lResult = RegCreateKey(MyRegister.hKey, myNewSKey, rtKey)
If GetStringRegisterError("ERROR", "CREATEKEY", 0, lResult) = "" Then
If CreateAndRoot = True Then
MyRegister.hSKey = rtKey
MyRegister.SubKey = myNewSKey
SetRoot myNewSKey
End If
End If
End Sub
Public Sub CreateSubKey(ByVal myNewSKey As String, Optional CreateAndRoot As Boolean = False)
Dim lResult As Long, rtKey As Long
If CheckRoot(myNewSKey) = True Then Exit Sub
lResult = RegCreateKey(MyRegister.hSKey, myNewSKey, rtKey)
If GetStringRegisterError("ERROR", "CreateSubKey", 0, lResult) = "" Then
If CreateAndRoot = True Then
MyRegister.hSKey = rtKey
MyRegister.SubKey = MyRegister.SubKey & "\" & myNewSKey
SetSubRoot MyRegister.SubKey
End If
End If
End Sub
Public Function CheckRoot(ByVal mySKey As String) As Boolean
Dim hRead As Long, hResult As Long
hResult = RegOpenKeyEx(MyRegister.hKey, mySKey, 0, KEY_READ, hRead)
If hResult = 0 Then RegCloseKey hRead
Call GetStringRegisterError("ERROR", "CheckRoot", 0, lResult)
End Function
Public Sub OpenRegister(myKey As enREG_KEYS)
If MyRegister.hKey > 0 Then CloseRegister
Call ClearRegister
MyRegister.hKey = myKey
End Sub
Public Sub SetRoot(mySKey As String)
Dim lResult As Long
MyRegister.SubKey = mySKey
If MyRegister.hSKey > 0 Then RegCloseKey MyRegister.hSKey
lResult = RegOpenKey(MyRegister.hKey, MyRegister.SubKey, MyRegister.hSKey)
Call GetStringRegisterError("ERROR", "SetRoot", 0, lResult)
End Sub
Public Sub SetSubRoot(mySKey As String)
Dim lResult As Long
If Not MyRegister.SubKey = mySKey Then
MyRegister.SubKey = MyRegister.SubKey & "\" & mySKey
End If
If MyRegister.hSKey > 0 Then RegCloseKey MyRegister.hSKey
lResult = RegOpenKey(MyRegister.hKey, MyRegister.SubKey, MyRegister.hSKey)
Call GetStringRegisterError("ERROR", "SetRoot", 0, lResult)
End Sub
Public Sub CloseRegister()
RegCloseKey MyRegister.hSKey
Call ClearRegister
End Sub
Private Sub ClearRegister()
With MyRegister
.hKey = 0
.hSKey = 0
.SubKey = ""
.TypeKey = 0
.HaveError = False
.HaveErrorDescription = ""
End With
End Sub
Private Function GetStringRegisterError(sLabel As String, sFunction As String, lTrueResult As Long, ByVal lResult As Long) As String
'Error ; Function Error ;
'Retour Query ; Key Handle ; SubKey Handle ; Root String
Dim rtERR As String
If lTrueResult = lResult Then
MyRegister.HaveError = False
rtERR = ""
Else
MyRegister.HaveError = True
rtERR = UCase(sLabel) & "[;]" & _
UCase(sFunction) & "[;]" & _
CStr(lResult) & "[;]" & _
MyRegister.hKey & "[;]" & _
MyRegister.hSKey & "[;]" & _
MyRegister.SubKey & "[;]"
End If
MyRegister.HaveErrorDescription = rtERR
GetStringRegisterError = rtERR
End Function
Conclusion :
Petit exemple avec une liste avec toutes les clés dans l'ordre (voir enREG_KEYS),
Un textbox ou est inscrit le chemin, et un textbox avec le nom de la clé a lire.
modRegistre.OpenRegister CLng(&H80000000 + Me.lstKeyRoot.ListIndex)
Call modRegistre.SetRoot(Me.txtRegSubRoot)
rt = modRegistre.GetValue(Me.txtRegSubValue)
If rt <> "" Then
MsgBox "Lecture avec succès !" & vbNewLine & vbNewLine & _
"hKey= " & MyRegister.hKey & vbNewLine & _
"hSKey= " & MyRegister.hSKey & vbNewLine & _
"SubKey= " & MyRegister.SubKey & vbNewLine & _
"TypeKey= " & MyRegister.TypeKey & vbNewLine & _
"HaveError= " & MyRegister.HaveError & vbNewLine & _
"ErrorDescription= " & MyRegister.HaveErrorDescription & vbNewLine & vbNewLine & _
"Value= " & rt, vbInformation
Else
MsgBox "Erreur de Lecture !" & vbNewLine & vbNewLine & _
"hKey= " & MyRegister.hKey & vbNewLine & _
"hSKey= " & MyRegister.hSKey & vbNewLine & _
"SubKey= " & MyRegister.SubKey & vbNewLine & _
"TypeKey= " & MyRegister.TypeKey & vbNewLine & _
"HaveError= " & MyRegister.HaveError & vbNewLine & _
"ErrorDescription= " & MyRegister.HaveErrorDescription, vbExclamation
End If
modRegistre.CloseRegister
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.