Base de registre !!
z980x
Messages postés
897
Date d'inscription
jeudi 6 juin 2002
Statut
Membre
Dernière intervention
26 juillet 2007
-
29 juin 2002 à 10:14
zeunz Messages postés 200 Date d'inscription jeudi 26 février 2004 Statut Membre Dernière intervention 30 juin 2008 - 15 août 2004 à 00:19
zeunz Messages postés 200 Date d'inscription jeudi 26 février 2004 Statut Membre Dernière intervention 30 juin 2008 - 15 août 2004 à 00:19
A voir également:
- Base de registre !!
- Base de données javascript - Conseils pratiques -Javascript
- Connexion base de données - Conseils pratiques -PHP
- Nomenclature base de données - Conseils pratiques -PHP
- Ebp impossible de se connecter à la base de données ✓ - Forum SQL
- Location base de données agence immobilière ✓ - Forum Visual Basic 6
2 réponses
Derrick soft
Messages postés
97
Date d'inscription
jeudi 10 mai 2001
Statut
Membre
Dernière intervention
20 juin 2005
29 juin 2002 à 11:06
29 juin 2002 à 11:06
Bonjour,
Mettez les section dans chaque fichier àdéquate et exécuter.
[ProjetVB]##########################################################################
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\WINDOWS\SYSTEM\stdole2.tlb#OLE Automation
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Module=Registry; Registry.bas
Form=Reg.frm
IconForm="Reg"
Startup="Reg"
HelpFile=""
Title="Base de registre"
ExeName32="BaseDeRegistre.exe"
Command32=""
Name="BaseDeRegistgre"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0
[ModuleVB]##########################################################################
Attribute VB_Name = "Registry"
Option Explicit
Public Type valeur
nom As String
type As Long
data() As Byte
End Type
'API nécessaires
' Pour se connecter une base de registre distante
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hkey As Long, phkResult As Long) As Long
' pour énumérer les valeures d'une clé ouverte
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 Byte, lpcbData As Long) As Long
' pour énumérer les sous clé d'une clé ouverte
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
'pour ouvrir une clé
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
'pour fermer une clé ouverte
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
'pour créer une clé
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'pour supprimer une clé ouverte
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
'pour supprimer une valeur
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
'pour lire une valeur
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
'pour fixer ou créer une valeur
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
' const propre à l'appli
Global Const VBREG_QUICKVIEW = 1
Global Const VBREG_SHOWEXT = 2
' const prises WINERROR.H
Global Const VBREG_ERROR_SUCCESS As Long = 0 ' pas d'erreur
Global Const VBREG_ERROR_INVALID_PARAMETER As Long = 87 ' Erreur dans les paramètres d'appel
Global Const VBREG_ERROR_NO_MORE_ITEMS As Long = 259 ' Il n'a plus de d'items à lister
Global Const VBREG_ERROR_ACCESS_DENIED As Long = 5 ' l'accés est refusé
Global Const VBREG_ERROR_INVALID_HANDLE As Long = 6 ' handel invalide
Global Const VBREG_ERROR_FILE_NOT_FOUND As Long = 2 ' référence non existente
Global Const VBREG_ERROR_MORE_DATA As Long = 234 ' buffer trop petit pour stocker les data
' const prises WINREG.H
Global Const VBREG_HKEY_CLASSES_ROOT As Long = &H80000000
Global Const VBREG_HKEY_CURRENT_USER As Long = &H80000001
Global Const VBREG_HKEY_LOCAL_MACHINE As Long = &H80000002
Global Const VBREG_HKEY_USERS As Long = &H80000003
Global Const VBREG_HKEY_PERFORMANCE_DATA As Long = &H80000004
Global Const VBREG_HKEY_CURRENT_CONFIG As Long = &H80000005
Global Const VBREG_HKEY_DYN_DATA As Long = &H80000006
' const prises WINNT.H
Global Const VBREG_REG_NONE As Long = 0
Global Const VBREG_REG_SZ As Long = 1
Global Const VBREG_REG_EXPAND_SZ As Long = 2
Global Const VBREG_REG_BINARY As Long = 3
Global Const VBREG_REG_DWORD As Long = 4
Global Const VBREG_REG_DWORD_BIG_ENDIAN As Long = 5
Global Const VBREG_REG_LINK As Long = 6
Global Const VBREG_REG_MULTI_SZ As Long = 7
Global Const VBREG_REG_RESOURCE_LIST As Long = 8
Global Const VBREG_REG_FULL_RESOURCE_DESCRIPTOR As Long = 9
Global Const VBREG_REG_RESOURCE_REQUIREMENTS_LIST As Long = 10
' const prises WINNT.H
Global Const VBREG_KEY_QUERY_VALUE As Long = &H1
Global Const VBREG_KEY_SET_VALUE As Long = &H2
Global Const VBREG_KEY_CREATE_SUB_KEY As Long = &H4
Global Const VBREG_KEY_ENUMERATE_SUB_KEYS As Long = &H8
Global Const VBREG_KEY_NOTIFY As Long = &H10
Global Const VBREG_KEY_CREATE_LINK As Long = &H20
Global Const VBREG_KEY_READ As Long = VBREG_KEY_QUERY_VALUE Or VBREG_KEY_ENUMERATE_SUB_KEYS Or VBREG_KEY_NOTIFY
Global Const VBREG_KEY_WRITE As Long = VBREG_KEY_SET_VALUE Or VBREG_KEY_CREATE_SUB_KEY
Global Const VBREG_KEY_EXECUTE As Long = VBREG_KEY_READ
Global Const VBREG_KEY_ALL_ACCESS As Long = VBREG_KEY_QUERY_VALUE + VBREG_KEY_SET_VALUE + VBREG_KEY_CREATE_SUB_KEY + VBREG_KEY_ENUMERATE_SUB_KEYS + VBREG_KEY_NOTIFY + VBREG_KEY_CREATE_LINK
Private Function decode_hkey(Key As Variant) As Long
Dim STR_type As String
decode_hkey = VBREG_ERROR_INVALID_PARAMETER
STR_type = TypeName(Key)
If STR_type <> "Long" And STR_type <> "String" Then
Exit Function
End If
If STR_type = "Long" Then
decode_hkey = Key
Else
Select Case Key
Case "HKEY_CLASSES_ROOT"
decode_hkey = VBREG_HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
decode_hkey = VBREG_HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
decode_hkey = VBREG_HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
decode_hkey = VBREG_HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
decode_hkey = VBREG_HKEY_PERFORMANCE_DATA
Case "HKEY_DYN_DATA"
decode_hkey = VBREG_HKEY_DYN_DATA
Case "HKEY_CURRENT_CONFIG"
decode_hkey = VBREG_HKEY_CURRENT_CONFIG
Case Else
Exit Function
End Select
End If
End Function
Public Function open_remote_key(Remote_Host As String, Base_key As Variant, Optional resultat As Long) As Long
' cette fonction sera utilisée pour obtenir un handle de clé sur un morceau
' de la base de registre d'un ordinateur distant
'-----------------------------------------------------------------------------
' param : Remote_Host as string au format UNV ("\\host_name") ou
' ("\\Adress_IP")
' Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
' --------------------------------------------------------------
' |cette clé peut être dans tous les cas |
' | VBREG_HKEY_LOCAL_MACHINE, VBREG_HKEY_USERS |
' |et en plus sous WinNT VBREG_HKEY_PERFORMANCE_DATA |
' |et en plus sous 95/98 VBREG_HKEY_DYN_DATA, |
' | VBREG_HKEY_CURRENT_CONFIG |
' |mais jamais VBREG_HKEY_CLASSES_ROOT, VBREG_HKEY_CURRENT_USER|
' --------------------------------------------------------------
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé ouverte sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
open_remote_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then open_remote_key LNG_key2: Exit Function
resultat = RegConnectRegistry(ByVal Remote_Host, LNG_key2, LNG_key1)
'MsgBox resultat & " " & LNG_key1
If resultat = 1114 Then MsgBox "Impossible de joindre la base de registre du poste distant"
open_remote_key = LNG_key1
End Function
Public Function open_a_key(Base_key As Variant, SubKey As String, Sam As Long, Optional resultat As Long) As Long
' cette fonction sera utilisée pour obtenir un handle de clé sur un morceau
' de la base de registre
'-----------------------------------------------------------------------------
' param : Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
'
' SubKey as string contient le chemin de la sous clé à ouvrir
' EX : "SOFTWARE\test\test2"
' si key vaut un handle d'une clé ouverte, subkey n'est que
' la partie fille de la registry
' si key vaut un handle de clé de base, subkey sera le chemin
' complet de la clé ciblée
'
' Sam as long contient les option d'ouverture
' EX : VBREG_KEY_ALL_ACCESS
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé ouverte sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
open_a_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then open_a_key LNG_key2: Exit Function
resultat = RegOpenKeyEx(LNG_key2, SubKey, 0&, ByVal Sam, LNG_key1)
open_a_key = LNG_key1
End Function
Public Function close_a_key(Base_key As Long) As Long
' ferme la clé ouverte avec son handle d'ouverture
' ce handel ne pas être une constente prédéfinie VBREG_HKEY_LOCAL_MACHINE...
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
close_a_key = RegCloseKey(Base_key)
End Function
Public Function create_a_key(Base_key As Variant, SubKey As String, Optional resultat As Long) As Long
' cette fonction sera utilisée pour créer une sous clé sur un morceau
' de la base de registre
'-----------------------------------------------------------------------------
' param : Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
'
' SubKey as string contient le chemin de la sous clé à ouvrir
' EX : "SOFTWARE\test\test2"
' si key vaut un handle d'une clé ouverte, subkey n'est que
' la partie fille de la registry
' si key vaut un handle de clé de base, subkey sera le chemin
' complet de la clé ciblée
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé crée sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
create_a_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then create_a_key LNG_key2: Exit Function
resultat = RegCreateKey(LNG_key2, SubKey, LNG_key1)
create_a_key = LNG_key1
End Function
Public Function delete_a_key(Parent_Key As Long, SubKey As String) As Long
' détruit la clé dont on donne le handle d'ouverture de la clé parente
' ATTENTION toute les filles seront détruite par récursivité
'-----------------------------------------------------------------------------
' param : Parent_Key as long handle d'ouverture de la clé parente
'
' SubKey as string chaine de caractaiResultat contenant la
' clé fille à supprimer
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim STR_keyname As String
Dim LNG_len As Long
Dim LNG_resultat As Long
Dim COL_subkeys As New Collection
Dim LNG_cnt As Long
LNG_resultat = get_subkeys(Parent_Key, COL_subkeys)
For LNG_cnt = 1 To COL_subkeys.Count
If COL_subkeys.Item(LNG_cnt) = SubKey Then
LNG_cnt = -1
Exit For
End If
Next LNG_cnt
If LNG_cnt <> -1 Then Exit Function
Do
STR_keyname = String(513, Chr$(0))
LNG_key1 = open_a_key(Parent_Key, SubKey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
delete_a_key = LNG_resultat
Exit Function
End If
LNG_resultat = RegEnumKey(LNG_key1, 0, ByVal STR_keyname, 512)
If LNG_resultat <> 0 Then
LNG_resultat = RegDeleteKey(Parent_Key, SubKey)
delete_a_key = LNG_resultat
Exit Do
Else
LNG_len = InStr(1, STR_keyname, Chr$(0)) If LNG_len >2 Then STR_keyname Left$(STR_keyname, LNG_len - 1)
delete_a_key = delete_a_key(LNG_key1, STR_keyname)
End If
Loop
End Function
Public Function get_values(Base_key As Long, retour() As valeur) As Long
' Cette fonction remplie la variable de retour avec les valeurs directement
' liées à la clé dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
' ou d'une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_USERS,VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
'
' retour as valeur est un tableau de type valeur vide
'-----------------------------------------------------------------------------
' retourne le nombre de valeurs sur un long
'-----------------------------------------------------------------------------
Dim LNG_index As Long
Dim STR_valname As String
Dim LNG_valtype As Long
Dim BYT_buffer(512) As Byte
Dim LNG_resultat As Long
Dim LNG_cnt1 As Long
Dim LNG_len As Long
Dim LNG_bufferlen As Long
LNG_cnt1 = 0
STR_valname = String(512, Chr$(0))
LNG_index = 0
Do
LNG_bufferlen = 512
LNG_resultat = RegEnumValue(Base_key, LNG_index, ByVal STR_valname, 512, 0&, LNG_valtype, BYT_buffer(0), LNG_bufferlen)
If LNG_resultat = 0 Then
LNG_len = InStr(1, STR_valname, Chr$(0))
ReDim Preserve retour(LNG_cnt1) As valeur
If LNG_len > 1 Then
retour(LNG_cnt1).nom = Left$(STR_valname, LNG_len - 1)
Else
retour(LNG_cnt1).nom = ""
End If
retour(LNG_cnt1).type = LNG_valtype
If LNG_bufferlen <> 0 Then
ReDim Preserve retour(LNG_cnt1).data(LNG_bufferlen - 1) As Byte
For LNG_len = 0 To LNG_bufferlen - 1
retour(LNG_cnt1).data(LNG_len) = BYT_buffer(LNG_len)
Next LNG_len
End If
LNG_cnt1 = LNG_cnt1 + 1
End If
LNG_index = LNG_index + 1
Loop While (LNG_resultat = 0)
get_values = LNG_index - 1
End Function
Public Function get_subkeys(Base_key As Long, Optional retour As Variant) As Long
' Cette fonction remplie la variable de retour avec les sous-clé directement
' liées à celle dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
' ou d'une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_USERS,VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
'
' retour as variant est optionnel vous pouvez y passer
' une collection, une listbox, une combo box, ou un
' tableau de chaine vide
' si vous ne l'utilisez pas, la fonction retournera
' seulement le nombre de sous-clé files
'-----------------------------------------------------------------------------
' retourne le nombre de sous-clé fille sur un long
'-----------------------------------------------------------------------------
Dim LNG_index As Long
Dim STR_name As String
Dim STR_keyname As String
Dim STR_type As String
Dim LNG_resultat As Long
Dim LNG_len As Long
Dim LNG_cnt1 As Long
LNG_cnt1 = 0
STR_name = String(513, Chr$(0))
STR_type = TypeName(retour)
LNG_index = 0
Do
LNG_resultat = RegEnumKey(Base_key, LNG_index, ByVal STR_name, 512)
If LNG_resultat = 0 And STR_type <> "Error" Then
LNG_len = InStr(1, STR_name, Chr$(0)) If LNG_len >2 Then STR_keyname Left$(STR_name, LNG_len - 1)
If STR_type = "Collection" Then retour.Add Item:=STR_keyname
If STR_type = "ListBox" Then retour.AddItem STR_keyname
If STR_type = "ComboBox" Then retour.AddItem STR_keyname
If STR_type = "String()" Then
ReDim Preserve retour(LNG_cnt1) As String
retour(LNG_cnt1) = STR_keyname
LNG_cnt1 = LNG_cnt1 + 1
End If
End If
LNG_index = LNG_index + 1
Loop While (LNG_resultat = 0)
get_subkeys = LNG_index - 1
End Function
Public Function create_a_value(Base_key As Long, value_type As Long, value_name As String, value_data As Variant) As Long
' cette fonction créera une donnée fille de la clé dont vous fournissez
' le handle d'ouverture
'-----------------------------------------------------------------------------
' param : key as long provenant d'une précédente ouverture
'
' value_type as long une des constente prédéfie
' VBREG_REG_NONE,VBREG_REG_NONE,VBREG_REG_EXPAND_SZ,VBREG_REG_BINARY,VBREG_REG_DWORD
' VBREG_REG_DWORD_BIG_ENDIAN,VBREG_REG_LINK,VBREG_REG_MULTI_SZ
' VBREG_REG_RESOURCE_LIST,VBREG_REG_FULL_RESOURCE_DESCRIPTOR
' VBREG_REG_RESOURCE_REQUIREMENTS_LIST
'
' value_name as string chaine de caractaires représentant le nom
' que vous voulez donner à votre donnée fille
'
' value_data as variant vous pouvez y passer :
' un tableau de d'octet 'Byte()'
' un tableau de cahine 'String()'
' un 'String'
' un 'Long'
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
' fonctionnement :
' un value_data donné en tant que Byte() sera transformé en un String et
' repassera dans la moulinette
' un value_data donné en tant que String() ne pourra être utilisé uniquement
' avec un value_type REG_MULTY_SZ. le value_type sera automatiquement changé
' en REG_MULTY_SZ
' un value_data String ou Byte() utilisé avec un value_type VBREG_REG_DWORD écrira un
' DWORD équivalent à la chaine de caractaires par VAL()
'-----------------------------------------------------------------------------
Dim STR_type As String
Dim STR_value As String
Dim LNG_value As Long
Dim BLN_cont As Boolean
Dim LNG_resultat As Long
STR_value "": LNG_value 0
STR_type = TypeName(value_data)
Do
BLN_cont = False
Select Case STR_type
Case "Byte()"
STR_value = tbyte_to_string(value_data)
STR_type = "String"
BLN_cont = True
Case "String()"
STR_value = tstring_to_string(value_data)
value_type = VBREG_REG_MULTI_SZ
STR_type = "String"
BLN_cont = True
Case "String"
STR_value = value_data
If value_type = VBREG_REG_MULTI_SZ Then
STR_value = Replace(STR_value, Chr$(13) + Chr$(10), Chr$(0)) + Chr$(0)
If Right$(STR_value, 2) <> Chr$(0) + Chr$(0) Then STR_value = STR_value + Chr$(0)
End If
If value_type = VBREG_REG_DWORD Then
LNG_value = Val(STR_value)
STR_type = "Long"
Else
End If
Case "Long"
LNG_value = value_data
End Select
Loop While BLN_cont
If STR_type = "Long" Then
LNG_resultat = RegSetValueEx(Base_key, value_name, 0&, VBREG_REG_DWORD, LNG_value, 4)
create_a_value = LNG_resultat
Else
LNG_resultat = RegSetValueEx(Base_key, value_name, 0&, value_type, ByVal STR_value, Len(STR_value))
create_a_value = LNG_resultat
End If
End Function
Public Function read_a_value(Base_key As Long, value_name As String, Optional value_type As Long) As Variant
' cette fonction retournera la donnée contenue par la valeur fille de la clé
' dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
' value_name as string chaine de caractaires représentant le nom
' de la valeur dont vous voulez récupérer la
' donnée
'
' value_type as long est un paramètre optionel dans lequel sera
' stoqué le type de donnée contenu
'-----------------------------------------------------------------------------
' retourne le contenue dans une variable de type variante
'-----------------------------------------------------------------------------
Dim STR_value As String
Dim LNG_value As Long
Dim LNG_lenbuffer As Long
Dim LNG_resultat As Long
Dim LNG_type As Long
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, LNG_type, 0&, LNG_lenbuffer)
value_type = LNG_type
If LNG_type = VBREG_REG_DWORD Then
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, VBREG_REG_DWORD, LNG_value, 4)
read_a_value = LNG_value
Else
STR_value = String(LNG_lenbuffer, Chr$(0))
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, LNG_type, ByVal STR_value, LNG_lenbuffer) If LNG_type VBREG_REG_SZ Then STR_value Left$(STR_value, Len(STR_value) - 1)
If LNG_type = VBREG_REG_MULTI_SZ Then
STR_value = Left$(STR_value, Len(STR_value) - 2)
STR_value = Replace(STR_value, Chr$(0), Chr$(13) + Chr$(10))
End If
read_a_value = STR_value
End If
End Function
Public Function delete_all_values(Base_key As Long) As Long
' cette fonction détruiera les valeurs contenues dans une clé
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
'-----------------------------------------------------------------------------
' retourne le nombre de valeurs détruites
'-----------------------------------------------------------------------------
Dim ARY_valeur() As valeur
Dim LNG_nbvaleur As Long
Dim LNG_resultat As Long
Dim LNG_cnt As Long
LNG_nbvaleur = get_values(Base_key, ARY_valeur)
For LNG_cnt = 0 To LNG_nbvaleur - 1
LNG_resultat = delete_a_value(Base_key, ARY_valeur(LNG_cnt).nom)
Next LNG_cnt
End Function
Public Function delete_a_value(Base_key As Long, value_name As String) As Long
' cette fonction détruiera la valeur dont vous donné le handel d'ouverture de
' la clé parente
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
' value_name as string chaine de caractaires représentant le nom
' de la valeur que vous voulez détruire
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
delete_a_value = RegDeleteValue(Base_key, ByVal value_name)
End Function
Public Sub save_a_reg_file(Base_key As String, file_name As String)
' cette procédure sauvegardera la clé mére dont vous founirez le chemin
' dans un fichier de type REG
'-----------------------------------------------------------------------------
' param : Base_Key as string contient le chemin de la clé à sauvegarder
' EX : "VBREG_HKEY_LOCAL_MACHINE\SOFTWARE\test"
'
' file_name as string contien le du fichier de sauvegarde
'-----------------------------------------------------------------------------
Dim INT_filehandel As Integer
Dim STR_hkey As String
Dim STR_subkey As String
Dim STR_parentkey As String
Dim STR_tampo As String
Dim LNG_key As Long
Dim LNG_resultat As Long
STR_tampo = "[" + Base_key + "]"
STR_hkey = get_hkey(STR_tampo)
STR_subkey = get_subkey(STR_tampo)
STR_parentkey = STR_tampo
LNG_key = open_a_key(STR_hkey, STR_parentkey + "" + STR_subkey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
Exit Sub
End If
INT_filehandel = FreeFile
Open file_name For Output As #INT_filehandel
Print #INT_filehandel, "REGEDIT4"
Print #INT_filehandel, "[" + Base_key + "]"
Call save_the_values(LNG_key, INT_filehandel)
Call save_the_keys(LNG_key, Base_key, INT_filehandel)
Close #INT_filehandel
LNG_resultat = close_a_key(LNG_key)
End Sub
Private Sub save_the_keys(Base_key As Long, basekey_name As String, file_handel As Integer)
Dim LNG_resultat As Long
Dim LNG_key As Long
Dim STR_keyname As String
Dim LNG_pos As Long
Dim LNG_index As Long
Do
STR_keyname = String(513, Chr$(0))
LNG_resultat = RegEnumKey(Base_key, LNG_index, ByVal STR_keyname, 512)
If LNG_resultat <> 0 Then
Exit Do
Else
LNG_pos = InStr(1, STR_keyname, Chr$(0)) If LNG_pos >2 Then STR_keyname Left$(STR_keyname, LNG_pos - 1)
Print #file_handel, "[" + basekey_name + "" + STR_keyname + "]"
LNG_key = open_a_key(Base_key, STR_keyname, VBREG_KEY_ALL_ACCESS, LNG_resultat)
Call save_the_values(LNG_key, file_handel)
Call save_the_keys(LNG_key, basekey_name + "" + STR_keyname, file_handel)
LNG_resultat = close_a_key(LNG_key)
End If
LNG_index = LNG_index + 1
Loop
End Sub
Private Sub save_the_values(Base_key As Long, file_handel As Integer)
Dim ARY_valeurs() As valeur
Dim LNG_nbvaleurs As Long
Dim STR_linetowrite As String
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim VRT_cnt3 As Variant
LNG_nbvaleurs = get_values(Base_key, ARY_valeurs)
For LNG_cnt1 = 0 To LNG_nbvaleurs - 1
If ARY_valeurs(LNG_cnt1).nom = "" Then
STR_linetowrite = "@="
Else
STR_linetowrite = Chr$(34) + ARY_valeurs(LNG_cnt1).nom + Chr$(34) + "="
End If
Select Case ARY_valeurs(LNG_cnt1).type
Case VBREG_REG_SZ
STR_linetowrite = STR_linetowrite + Chr$(34) + tbyte_to_string(ARY_valeurs(LNG_cnt1).data)
STR_linetowrite = Left$(STR_linetowrite, Len(STR_linetowrite) - 1) + Chr$(34)
Case VBREG_REG_DWORD
STR_linetowrite = STR_linetowrite + "dword:"
For LNG_cnt2 = 3 To 0 Step -1
STR_linetowrite = STR_linetowrite + Hex$(ARY_valeurs(LNG_cnt1).data(LNG_cnt2))
Next LNG_cnt2
Case Else
STR_linetowrite = STR_linetowrite + "hex(" + Trim$(Hex$(ARY_valeurs(LNG_cnt1).type)) + "):"
For Each VRT_cnt3 In ARY_valeurs(LNG_cnt1).data
STR_linetowrite = STR_linetowrite + Trim$(Hex$(VRT_cnt3)) + ","
Next VRT_cnt3
STR_linetowrite = Left$(STR_linetowrite, Len(STR_linetowrite) - 1)
End Select
Print #file_handel, STR_linetowrite
Next LNG_cnt1
End Sub
Public Sub restore_a_reg_file(file_name As String)
' cette procédure détruira la clé mére contenue dans lefichier REG
' et fera la restoration de celui-ci
'-----------------------------------------------------------------------------
Dim BYT_car1 As Byte
Dim BYT_car2 As Byte
Dim STR_tempo1 As String
Dim STR_tempo2 As String
Dim LNG_linetype As Long
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_hkey As String
Dim STR_subkey As String
Dim STR_parentkey As String
Dim STR_valuename As String
Dim LNG_resultat As Long
Dim INT_filehandel As Integer
Dim BYT_finligne As Byte
Dim LNG_debutpath As Long
Dim LNG_finpath As Long
BYT_finligne 0: BYT_car1 0: BYT_car2 = 0
INT_filehandel = FreeFile
Open file_name For Binary As INT_filehandel
While (Not EOF(INT_filehandel))
Get #INT_filehandel, , BYT_car1
If BYT_finligne = 1 And BYT_car1 <> 34 And BYT_car1 <> 64 And BYT_car1 <> 91 And (Not EOF(INT_filehandel)) Then
BYT_finligne = 0
End If If BYT_finligne 1 And (BYT_car1 34 Or BYT_car1 = 64 Or BYT_car1 = 91 Or EOF(INT_filehandel)) Then
BYT_finligne = 2
LNG_linetype = 0
STR_tempo1 = Mid$(STR_tempo2, 1, 1) If STR_tempo1 "[" Then LNG_linetype 1 If STR_tempo1 Chr$(34) Or STR_tempo1 "@" Then LNG_linetype = 2
If LNG_linetype = 1 Then
LNG_debutpath = InStr(STR_tempo2, "[")
LNG_finpath = InStr(STR_tempo2, "]")
STR_tempo2 = Mid$(STR_tempo2, LNG_debutpath, LNG_finpath - LNG_debutpath + 1)
End If
If LNG_linetype = 2 Then
STR_tempo1 = Right$(STR_tempo2, 2) While (STR_tempo1 Chr$(13) + Chr$(10) Or STR_tempo1 Chr$(10) + Chr$(13))
STR_tempo2 = Left$(STR_tempo2, Len(STR_tempo2) - 2)
STR_tempo1 = Right$(STR_tempo2, 2)
Wend
End If
End If If (BYT_car1 13 And BYT_car2 10) Or (BYT_car1 = 10 And BYT_car2 = 13) Then
BYT_finligne = 1
End If
If BYT_finligne = 2 Then
If LNG_linetype = 1 Then
LNG_resultat = close_a_key(LNG_key1)
STR_hkey = get_hkey(STR_tempo2)
STR_subkey = get_subkey(STR_tempo2)
STR_parentkey = STR_tempo2
LNG_key1 = open_a_key(STR_hkey, STR_parentkey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
LNG_resultat = delete_a_key(LNG_key1, STR_subkey)
LNG_key1 = create_a_key(STR_hkey, STR_parentkey + "" + STR_subkey, LNG_resultat)
End If
If LNG_linetype = 2 Then
STR_valuename = get_value_name(STR_tempo2)
LNG_linetype = get_value_type(STR_tempo2)
LNG_resultat = create_a_value(LNG_key1, LNG_linetype, STR_valuename, STR_tempo2)
End If
STR_tempo2 = Chr$(BYT_car1)
BYT_finligne = 0
Else
STR_tempo2 = STR_tempo2 + Chr$(BYT_car1)
BYT_car2 = BYT_car1
End If
Wend
Close INT_filehandel
End Sub
Private Function get_hkey(key_path As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(key_path)
For LNG_cnt = 1 To LNG_len
STR_car = Mid$(key_path, LNG_cnt, 1)
If STR_car <> "[" And STR_car <> "" Then
STR_tempo = STR_tempo + STR_car
End If
If STR_car = "" Then
key_path = Right$(key_path, LNG_len - LNG_cnt)
key_path = Left$(key_path, Len(key_path) - 1)
Exit For
End If
Next LNG_cnt
get_hkey = STR_tempo
End Function
Private Function get_subkey(key_path As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(key_path)
For LNG_cnt = LNG_len To 1 Step -1
STR_car = Mid$(key_path, LNG_cnt, 1)
If STR_car = "" Then
STR_tempo = Right$(key_path, Len(key_path) - LNG_cnt)
key_path = Left$(key_path, LNG_cnt - 1)
Exit For
End If
Next LNG_cnt
get_subkey = STR_tempo
End Function
Private Function get_value_name(value_line As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(value_line)
If Mid$(value_line, 1, 1) = "@" Then
get_value_name = ""
value_line = Mid$(value_line, 3, LNG_len - 2)
Exit Function
End If
For LNG_cnt = 1 To LNG_len
STR_car = Mid$(value_line, LNG_cnt, 1)
If STR_car <> Chr$(34) And STR_car <> "=" Then
STR_tempo = STR_tempo + STR_car
End If
If STR_car = "=" Then
value_line = Right$(value_line, LNG_len - LNG_cnt)
Exit For
End If
Next LNG_cnt
get_value_name = STR_tempo
End Function
Private Function get_value_type(value_line As String) As Long
Dim LNG_len As Long
Dim STR_tempo1 As String
Dim STR_tempo2 As String
Dim STR_tempo3 As String
Dim STR_tempo4 As String
Dim STR_tempo5 As String
LNG_len = Len(value_line)
STR_tempo1 = Mid$(value_line, 1, 1)
STR_tempo2 = Mid$(value_line, 1, 4)
STR_tempo3 = Mid$(value_line, 1, 3)
STR_tempo4 = Mid$(value_line, 1, 5)
STR_tempo5 = Mid$(value_line, 5, 1)
If STR_tempo3 "hex" And STR_tempo2 <> "hex(" Then STR_tempo2 "hex(": STR_tempo5 = "3"
If STR_tempo1 = Chr$(34) Then
get_value_type = VBREG_REG_SZ
value_line = Mid$(value_line, 2, LNG_len - 2)
Exit Function
End If
If STR_tempo2 = "hex(" Then
get_value_type = Val("&H" + STR_tempo5)
value_line = Right$(value_line, LNG_len - 7) If get_value_type 7 Then value_line Left$(value_line, Len(value_line) - 1)
value_line = get_value_BI(value_line)
Exit Function
End If If STR_tempo4 "dword" Or STR_tempo4 "DWORD" Then
get_value_type = VBREG_REG_DWORD
value_line = Right$(value_line, LNG_len - 6)
value_line = Str$(Val("&H" + value_line))
Exit Function
End If
get_value_type = 0
End Function
Private Function get_value_BI(value_line As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim STR_car As String
Dim LNG_cnt As Long
value_line = Replace(value_line, ",", "")
LNG_len = Len(value_line)
For LNG_cnt = 1 To LNG_len Step 2
STR_car = Mid$(value_line, LNG_cnt, 2)
STR_tempo = STR_tempo + Chr$(Val("&H" + STR_car))
Next LNG_cnt
get_value_BI = STR_tempo
End Function
Public Sub delete_association(Ext_name As String)
' cette procédure détruira une association entre un type de fichier et une
' application
'-----------------------------------------------------------------------------
' param : Ext_name as string extention de votre type de fichier
' EX=".xxx"
'-----------------------------------------------------------------------------
Dim LNG_key As Long
Dim LNG_resultat As Long
Dim STR_tempo As String
LNG_key = open_a_key(VBREG_HKEY_CLASSES_ROOT, Ext_name, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
LNG_key = open_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + Ext_name, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then Exit Sub
End If
STR_tempo = read_a_value(LNG_key, "")
LNG_resultat = close_a_key(LNG_key)
LNG_key = open_a_key(VBREG_HKEY_CLASSES_ROOT, "", VBREG_KEY_ALL_ACCESS)
LNG_resultat = delete_a_key(LNG_key, Ext_name)
LNG_resultat = delete_a_key(LNG_key, STR_tempo)
LNG_resultat = close_a_key(LNG_key)
LNG_key = open_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes", VBREG_KEY_ALL_ACCESS)
LNG_resultat = delete_a_key(LNG_key, Ext_name)
LNG_resultat = delete_a_key(LNG_key, STR_tempo)
close_a_key (LNG_key)
End Sub
Public Sub create_association(Ext_name As String, App_name As String, Cmd_lines As Variant, Icone As String, Comment As String, Options As Long)
' cette procédure créera une association entre un type de fichier et une
' application
'-----------------------------------------------------------------------------
' param : Ext_name as string extention de votre type de fichier
' EX=".xxx"
'
' App_name as string nom de votre programme
'
' Cmd_line as variant contient un tableau de string
' var(0,n)=nom de l'action
' var(1,n)=command à exécuter
'
' Icone as string contient le fichier .ico de l'icone
' représentant votre type de fichiers
'
' Comment as string ligne de commantaire qui sera incluse
' le gestionnaire des extentions (dans
' les option d'affichage d'un explorateur)
'
' Options as long option possible pour la création de
' votre association=
' VBREG_QUICKVIEW= autorise le quickview
' VBREG_SHOWEXT= oblige à montrer l'extention
'-----------------------------------------------------------------------------
Dim STR_filetype As String
Dim LNG_resultat As Long
Dim LNG_key As Long
Dim STR_type As String
Dim STR_shellname As String
Dim STR_shellcommand As String
Dim BLN_quickview As Boolean
Dim BLN_showext As Boolean
Dim LNG_cnt As Long
If Options And VBREG_QUICKVIEW VBREG_QUICKVIEW Then BLN_quickview True If Options And VBREG_SHOWEXT VBREG_SHOWEXT Then BLN_showext True
STR_type = TypeName(Cmd_lines)
If STR_type <> "String()" Then Exit Sub
STR_filetype = App_name + " files"
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, Ext_name)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_filetype)
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Comment)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_BINARY, "EditFlags", Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)) If BLN_showext True Then LNG_resultat create_a_value(LNG_key, VBREG_REG_BINARY, "AlwaysShowExt", "")
LNG_key = create_a_key(LNG_key, "DefaultIcon")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Icone)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + Ext_name)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_filetype)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Comment)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_BINARY, "EditFlags", Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)) If BLN_showext True Then LNG_resultat create_a_value(LNG_key, VBREG_REG_BINARY, "AlwaysShowExt", "")
LNG_key = create_a_key(LNG_key, "DefaultIcon")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Icone)
If BLN_quickview = True Then
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_key = create_a_key(LNG_key, "BLN_quickview")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", "*")
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_key = create_a_key(LNG_key, "BLN_quickview")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", "*")
End If
On Error GoTo fin_boucle
While (True)
STR_shellname = Cmd_lines(0, LNG_cnt)
STR_shellcommand = Cmd_lines(1, LNG_cnt)
If STR_shellname <> "" And STR_shellcommand <> "" Then
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_key = create_a_key(LNG_key, "shell" + STR_shellname + "\command")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_shellcommand)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_key = create_a_key(LNG_key, "shell" + STR_shellname + "\command")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_shellcommand)
End If
LNG_cnt = LNG_cnt + 1
Wend
fin_boucle:
On Error GoTo 0
End Sub
Private Function tbyte_to_string(byte_array As Variant) As String
Dim VRT_cnt As Variant
For Each VRT_cnt In byte_array
tbyte_to_string = tbyte_to_string + Chr$(VRT_cnt)
Next VRT_cnt
End Function
Private Function tstring_to_string(string_array As Variant) As String
Dim VRT_cnt As Variant
For Each VRT_cnt In string_array
If VRT_cnt <> "" Then tstring_to_string = tstring_to_string + VRT_cnt + Chr$(0)
Next VRT_cnt
tstring_to_string = tstring_to_string + Chr$(0)
End Function
Private Function string_to_tstring(a_string As String) As String()
Dim LNG_len As Long
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim STR_retour() As String
Dim STR_car As String
Dim STR_mot As String
LNG_cnt2 = 0
LNG_len = Len(a_string)
For LNG_cnt1 = 1 To LNG_len
STR_car = Mid$(a_string, LNG_cnt1, 1)
If STR_car = Chr$(0) Then
If STR_mot <> "" Then
ReDim Preserve STR_retour(LNG_cnt2) As String
STR_retour(LNG_cnt2) = STR_mot
LNG_cnt2 = LNG_cnt2 + 1
End If
STR_mot = ""
Else
STR_mot = STR_mot + STR_car
End If
Next LNG_cnt1
string_to_tstring = STR_retour
End Function
Private Function string_to_tbyte(a_string As String) As Byte()
Dim LNG_len As Long
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim BYT_retour() As Byte
Dim STR_car As String
LNG_cnt2 = 0
LNG_len = Len(a_string)
For LNG_cnt1 = 1 To LNG_len
STR_car = Mid$(a_string, LNG_cnt1, 1)
ReDim Preserve BYT_retour(LNG_cnt2) As Byte
BYT_retour(LNG_cnt2) = Asc(STR_car)
LNG_cnt2 = LNG_cnt2 + 1
Next LNG_cnt1
string_to_tbyte = BYT_retour
End Function
[FormVB]############################################################################
VERSION 5.00
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form Reg
Caption = "Accès Base de Registre"
ClientHeight = 6105
ClientLeft = 2685
ClientTop = 2460
ClientWidth = 9120
LinkTopic = "Form2"
ScaleHeight = 6105
ScaleWidth = 9120
Begin VB.CommandButton Command2
Caption = "Quitter"
Height = 495
Left = 7080
TabIndex = 24
Top = 5520
Width = 1935
End
Begin TabDlg.SSTab SSTab1
Height = 5295
Left = 120
TabIndex = 0
Top = 120
Width = 8895
_ExtentX = 15690
_ExtentY = 9340
_Version = 393216
Style = 1
Tabs = 2
TabHeight = 520
ShowFocusRect = 0 'False
TabCaption(0) = "Définition de Clés"
TabPicture(0) = "Reg.frx":0000
Tab(0).ControlEnabled= -1 'True
Tab(0).Control(0)= "hkey_box"
Tab(0).Control(0).Enabled= 0 'False
Tab(0).Control(1)= "subkey_box"
Tab(0).Control(1).Enabled= 0 'False
Tab(0).Control(2)= "keyaction_box"
Tab(0).Control(2).Enabled= 0 'False
Tab(0).Control(3)= "dst"
Tab(0).Control(3).Enabled= 0 'False
Tab(0).Control(4)= "remote"
Tab(0).Control(4).Enabled= 0 'False
Tab(0).ControlCount= 5
TabCaption(1) = "Définition de valeur"
TabPicture(1) = "Reg.frx":001C
Tab(1).ControlEnabled= 0 'False
Tab(1).Control(0)= "value_box"
Tab(1).Control(1)= "valueaction_box"
Tab(1).ControlCount= 2
Begin VB.CheckBox remote
Caption = "BDR Distant"
Height = 375
Left = 240
TabIndex = 44
Top = 4200
Width = 1575
End
Begin VB.TextBox dst
Height = 285
Left = 240
TabIndex = 43
Top = 3840
Width = 2655
End
Begin VB.Frame keyaction_box
Caption = "Actions"
Height = 1215
Left = 3120
TabIndex = 28
Top = 3240
Width = 5655
Begin VB.CommandButton key_exe
Cancel = -1 'True
Caption = "Exécute"
Height = 255
Left = 4440
TabIndex = 36
Top = 480
Width = 1095
End
Begin VB.TextBox key_to_creat
Height = 285
Left = 1800
TabIndex = 35
Top = 480
Width = 2535
End
Begin VB.OptionButton sup_key
Caption = "Efface la sous-clé"
Height = 255
Left = 120
TabIndex = 30
Top = 720
Width = 1695
End
Begin VB.OptionButton creat_key
Caption = "Créer la sous-clé"
Height = 255
Left = 120
TabIndex = 29
Top = 360
Width = 1695
End
End
Begin VB.Frame valueaction_box
Caption = "Actions"
Height = 1455
Left = -74880
TabIndex = 25
Top = 3720
Width = 8535
Begin VB.CommandButton value_exe
Caption = "Execute action"
Height = 615
Left = 2640
TabIndex = 40
Top = 480
Width = 2415
End
Begin VB.OptionButton sup_val
Caption = "Lit ou efface une valeur"
Height = 375
Left = 120
TabIndex = 27
Top = 840
Width = 2295
End
Begin VB.OptionButton creat_val
Caption = "Fixe ou créé une valeur"
Height = 375
Left = 120
TabIndex = 26
Top = 240
Width = 3855
End
End
Begin VB.Frame value_box
Caption = "Valeur de la sous clé"
Height = 3015
Left = -74880
TabIndex = 9
Top = 600
Width = 8535
Begin VB.ListBox value_name
Height = 1230
Left = 4080
TabIndex = 38
Top = 480
Width = 4335
End
Begin VB.OptionButton value_type
Caption = "REG_NONE"
Height = 255
Index = 0
Left = 120
TabIndex = 21
Top = 240
Width = 1215
End
Begin VB.OptionButton value_type
Caption = "REG_SZ"
Height = 255
Index = 1
Left = 120
TabIndex = 20
Top = 480
Width = 975
End
Begin VB.OptionButton value_type
Caption = "REG_EXPAND_SZ"
Height = 255
Index = 2
Left = 120
TabIndex = 19
Top = 720
Width = 1815
End
Begin VB.OptionButton value_type
Caption = "REG_BINARY"
Height = 255
Index = 3
Left = 120
TabIndex = 18
Top = 960
Width = 1335
End
Begin VB.OptionButton value_type
Caption = "REG_DWORD"
Height = 255
Index = 4
Left = 120
TabIndex = 17
Top = 1200
Width = 1455
End
Begin VB.OptionButton value_type
Caption = "REG_DWORD_BIG_ENDIAN (do not use)"
Height = 255
Index = 5
Left = 120
TabIndex = 16
Top = 1440
Width = 3375
End
Begin VB.OptionButton value_type
Caption = "REG_LINK (do not use)"
Height = 255
Index = 6
Left = 120
TabIndex = 15
Top = 1680
Width = 2055
End
Begin VB.OptionButton value_type
Caption = "REG_MULTI_SZ"
Height = 255
Index = 7
Left = 120
TabIndex = 14
Top = 1920
Width = 1575
End
Begin VB.OptionButton value_type
Caption = "REG_RESOURCE_LIST"
Height = 255
Index = 8
Left = 120
TabIndex = 13
Top = 2160
Width = 2295
End
Begin VB.OptionButton value_type
Caption = "REG_FULL_RESOURCE_DESCRIPTOR"
Height = 255
Index = 9
Left = 120
TabIndex = 12
Top = 2400
Width = 3375
End
Begin VB.OptionButton value_type
Caption = "REG_RESOURCE_REQUIREMENTS_LIST"
Height = 255
Index = 10
Left = 120
TabIndex = 11
Top = 2640
Width = 3495
End
Begin VB.TextBox value_multi_sz
Height = 1005
Left = 4080
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex
Mettez les section dans chaque fichier àdéquate et exécuter.
[ProjetVB]##########################################################################
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\WINDOWS\SYSTEM\stdole2.tlb#OLE Automation
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Module=Registry; Registry.bas
Form=Reg.frm
IconForm="Reg"
Startup="Reg"
HelpFile=""
Title="Base de registre"
ExeName32="BaseDeRegistre.exe"
Command32=""
Name="BaseDeRegistgre"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0
[ModuleVB]##########################################################################
Attribute VB_Name = "Registry"
Option Explicit
Public Type valeur
nom As String
type As Long
data() As Byte
End Type
'API nécessaires
' Pour se connecter une base de registre distante
Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hkey As Long, phkResult As Long) As Long
' pour énumérer les valeures d'une clé ouverte
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 Byte, lpcbData As Long) As Long
' pour énumérer les sous clé d'une clé ouverte
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
'pour ouvrir une clé
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
'pour fermer une clé ouverte
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
'pour créer une clé
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'pour supprimer une clé ouverte
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
'pour supprimer une valeur
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
'pour lire une valeur
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
'pour fixer ou créer une valeur
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
' const propre à l'appli
Global Const VBREG_QUICKVIEW = 1
Global Const VBREG_SHOWEXT = 2
' const prises WINERROR.H
Global Const VBREG_ERROR_SUCCESS As Long = 0 ' pas d'erreur
Global Const VBREG_ERROR_INVALID_PARAMETER As Long = 87 ' Erreur dans les paramètres d'appel
Global Const VBREG_ERROR_NO_MORE_ITEMS As Long = 259 ' Il n'a plus de d'items à lister
Global Const VBREG_ERROR_ACCESS_DENIED As Long = 5 ' l'accés est refusé
Global Const VBREG_ERROR_INVALID_HANDLE As Long = 6 ' handel invalide
Global Const VBREG_ERROR_FILE_NOT_FOUND As Long = 2 ' référence non existente
Global Const VBREG_ERROR_MORE_DATA As Long = 234 ' buffer trop petit pour stocker les data
' const prises WINREG.H
Global Const VBREG_HKEY_CLASSES_ROOT As Long = &H80000000
Global Const VBREG_HKEY_CURRENT_USER As Long = &H80000001
Global Const VBREG_HKEY_LOCAL_MACHINE As Long = &H80000002
Global Const VBREG_HKEY_USERS As Long = &H80000003
Global Const VBREG_HKEY_PERFORMANCE_DATA As Long = &H80000004
Global Const VBREG_HKEY_CURRENT_CONFIG As Long = &H80000005
Global Const VBREG_HKEY_DYN_DATA As Long = &H80000006
' const prises WINNT.H
Global Const VBREG_REG_NONE As Long = 0
Global Const VBREG_REG_SZ As Long = 1
Global Const VBREG_REG_EXPAND_SZ As Long = 2
Global Const VBREG_REG_BINARY As Long = 3
Global Const VBREG_REG_DWORD As Long = 4
Global Const VBREG_REG_DWORD_BIG_ENDIAN As Long = 5
Global Const VBREG_REG_LINK As Long = 6
Global Const VBREG_REG_MULTI_SZ As Long = 7
Global Const VBREG_REG_RESOURCE_LIST As Long = 8
Global Const VBREG_REG_FULL_RESOURCE_DESCRIPTOR As Long = 9
Global Const VBREG_REG_RESOURCE_REQUIREMENTS_LIST As Long = 10
' const prises WINNT.H
Global Const VBREG_KEY_QUERY_VALUE As Long = &H1
Global Const VBREG_KEY_SET_VALUE As Long = &H2
Global Const VBREG_KEY_CREATE_SUB_KEY As Long = &H4
Global Const VBREG_KEY_ENUMERATE_SUB_KEYS As Long = &H8
Global Const VBREG_KEY_NOTIFY As Long = &H10
Global Const VBREG_KEY_CREATE_LINK As Long = &H20
Global Const VBREG_KEY_READ As Long = VBREG_KEY_QUERY_VALUE Or VBREG_KEY_ENUMERATE_SUB_KEYS Or VBREG_KEY_NOTIFY
Global Const VBREG_KEY_WRITE As Long = VBREG_KEY_SET_VALUE Or VBREG_KEY_CREATE_SUB_KEY
Global Const VBREG_KEY_EXECUTE As Long = VBREG_KEY_READ
Global Const VBREG_KEY_ALL_ACCESS As Long = VBREG_KEY_QUERY_VALUE + VBREG_KEY_SET_VALUE + VBREG_KEY_CREATE_SUB_KEY + VBREG_KEY_ENUMERATE_SUB_KEYS + VBREG_KEY_NOTIFY + VBREG_KEY_CREATE_LINK
Private Function decode_hkey(Key As Variant) As Long
Dim STR_type As String
decode_hkey = VBREG_ERROR_INVALID_PARAMETER
STR_type = TypeName(Key)
If STR_type <> "Long" And STR_type <> "String" Then
Exit Function
End If
If STR_type = "Long" Then
decode_hkey = Key
Else
Select Case Key
Case "HKEY_CLASSES_ROOT"
decode_hkey = VBREG_HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
decode_hkey = VBREG_HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
decode_hkey = VBREG_HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
decode_hkey = VBREG_HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
decode_hkey = VBREG_HKEY_PERFORMANCE_DATA
Case "HKEY_DYN_DATA"
decode_hkey = VBREG_HKEY_DYN_DATA
Case "HKEY_CURRENT_CONFIG"
decode_hkey = VBREG_HKEY_CURRENT_CONFIG
Case Else
Exit Function
End Select
End If
End Function
Public Function open_remote_key(Remote_Host As String, Base_key As Variant, Optional resultat As Long) As Long
' cette fonction sera utilisée pour obtenir un handle de clé sur un morceau
' de la base de registre d'un ordinateur distant
'-----------------------------------------------------------------------------
' param : Remote_Host as string au format UNV ("\\host_name") ou
' ("\\Adress_IP")
' Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
' --------------------------------------------------------------
' |cette clé peut être dans tous les cas |
' | VBREG_HKEY_LOCAL_MACHINE, VBREG_HKEY_USERS |
' |et en plus sous WinNT VBREG_HKEY_PERFORMANCE_DATA |
' |et en plus sous 95/98 VBREG_HKEY_DYN_DATA, |
' | VBREG_HKEY_CURRENT_CONFIG |
' |mais jamais VBREG_HKEY_CLASSES_ROOT, VBREG_HKEY_CURRENT_USER|
' --------------------------------------------------------------
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé ouverte sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
open_remote_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then open_remote_key LNG_key2: Exit Function
resultat = RegConnectRegistry(ByVal Remote_Host, LNG_key2, LNG_key1)
'MsgBox resultat & " " & LNG_key1
If resultat = 1114 Then MsgBox "Impossible de joindre la base de registre du poste distant"
open_remote_key = LNG_key1
End Function
Public Function open_a_key(Base_key As Variant, SubKey As String, Sam As Long, Optional resultat As Long) As Long
' cette fonction sera utilisée pour obtenir un handle de clé sur un morceau
' de la base de registre
'-----------------------------------------------------------------------------
' param : Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
'
' SubKey as string contient le chemin de la sous clé à ouvrir
' EX : "SOFTWARE\test\test2"
' si key vaut un handle d'une clé ouverte, subkey n'est que
' la partie fille de la registry
' si key vaut un handle de clé de base, subkey sera le chemin
' complet de la clé ciblée
'
' Sam as long contient les option d'ouverture
' EX : VBREG_KEY_ALL_ACCESS
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé ouverte sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
open_a_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then open_a_key LNG_key2: Exit Function
resultat = RegOpenKeyEx(LNG_key2, SubKey, 0&, ByVal Sam, LNG_key1)
open_a_key = LNG_key1
End Function
Public Function close_a_key(Base_key As Long) As Long
' ferme la clé ouverte avec son handle d'ouverture
' ce handel ne pas être une constente prédéfinie VBREG_HKEY_LOCAL_MACHINE...
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
close_a_key = RegCloseKey(Base_key)
End Function
Public Function create_a_key(Base_key As Variant, SubKey As String, Optional resultat As Long) As Long
' cette fonction sera utilisée pour créer une sous clé sur un morceau
' de la base de registre
'-----------------------------------------------------------------------------
' param : Base_Key as variant vous pouvez y indiquer :
' - une chaine egale à
' "HKEY_CLASSES_ROOT","HKEY_CURRENT_USER","HKEY_LOCAL_MACHINE"
' "HKEY_USERS","HKEY_CURRENT_CONFIG","HKEY_DYN_DATA"
' "HKEY_PERFORMANCE_DATA"
' - un long egale une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_CURRENT_USER,VBREG_HKEY_USERS,
' VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
' HKEY_PERFORMANCE_DATA
' - un long provenant d'une précédente ouverture
'
' SubKey as string contient le chemin de la sous clé à ouvrir
' EX : "SOFTWARE\test\test2"
' si key vaut un handle d'une clé ouverte, subkey n'est que
' la partie fille de la registry
' si key vaut un handle de clé de base, subkey sera le chemin
' complet de la clé ciblée
'
' Resultat as long paramètre optionnel qui retournera le
' résultat de l'opération sur un long
'-----------------------------------------------------------------------------
' retourne le handle de la clé crée sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_type As String
create_a_key = 0
LNG_key2 = decode_hkey(Base_key) If LNG_key2 0 Then create_a_key LNG_key2: Exit Function
resultat = RegCreateKey(LNG_key2, SubKey, LNG_key1)
create_a_key = LNG_key1
End Function
Public Function delete_a_key(Parent_Key As Long, SubKey As String) As Long
' détruit la clé dont on donne le handle d'ouverture de la clé parente
' ATTENTION toute les filles seront détruite par récursivité
'-----------------------------------------------------------------------------
' param : Parent_Key as long handle d'ouverture de la clé parente
'
' SubKey as string chaine de caractaiResultat contenant la
' clé fille à supprimer
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
Dim LNG_key1 As Long
Dim STR_keyname As String
Dim LNG_len As Long
Dim LNG_resultat As Long
Dim COL_subkeys As New Collection
Dim LNG_cnt As Long
LNG_resultat = get_subkeys(Parent_Key, COL_subkeys)
For LNG_cnt = 1 To COL_subkeys.Count
If COL_subkeys.Item(LNG_cnt) = SubKey Then
LNG_cnt = -1
Exit For
End If
Next LNG_cnt
If LNG_cnt <> -1 Then Exit Function
Do
STR_keyname = String(513, Chr$(0))
LNG_key1 = open_a_key(Parent_Key, SubKey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
delete_a_key = LNG_resultat
Exit Function
End If
LNG_resultat = RegEnumKey(LNG_key1, 0, ByVal STR_keyname, 512)
If LNG_resultat <> 0 Then
LNG_resultat = RegDeleteKey(Parent_Key, SubKey)
delete_a_key = LNG_resultat
Exit Do
Else
LNG_len = InStr(1, STR_keyname, Chr$(0)) If LNG_len >2 Then STR_keyname Left$(STR_keyname, LNG_len - 1)
delete_a_key = delete_a_key(LNG_key1, STR_keyname)
End If
Loop
End Function
Public Function get_values(Base_key As Long, retour() As valeur) As Long
' Cette fonction remplie la variable de retour avec les valeurs directement
' liées à la clé dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
' ou d'une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_USERS,VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
'
' retour as valeur est un tableau de type valeur vide
'-----------------------------------------------------------------------------
' retourne le nombre de valeurs sur un long
'-----------------------------------------------------------------------------
Dim LNG_index As Long
Dim STR_valname As String
Dim LNG_valtype As Long
Dim BYT_buffer(512) As Byte
Dim LNG_resultat As Long
Dim LNG_cnt1 As Long
Dim LNG_len As Long
Dim LNG_bufferlen As Long
LNG_cnt1 = 0
STR_valname = String(512, Chr$(0))
LNG_index = 0
Do
LNG_bufferlen = 512
LNG_resultat = RegEnumValue(Base_key, LNG_index, ByVal STR_valname, 512, 0&, LNG_valtype, BYT_buffer(0), LNG_bufferlen)
If LNG_resultat = 0 Then
LNG_len = InStr(1, STR_valname, Chr$(0))
ReDim Preserve retour(LNG_cnt1) As valeur
If LNG_len > 1 Then
retour(LNG_cnt1).nom = Left$(STR_valname, LNG_len - 1)
Else
retour(LNG_cnt1).nom = ""
End If
retour(LNG_cnt1).type = LNG_valtype
If LNG_bufferlen <> 0 Then
ReDim Preserve retour(LNG_cnt1).data(LNG_bufferlen - 1) As Byte
For LNG_len = 0 To LNG_bufferlen - 1
retour(LNG_cnt1).data(LNG_len) = BYT_buffer(LNG_len)
Next LNG_len
End If
LNG_cnt1 = LNG_cnt1 + 1
End If
LNG_index = LNG_index + 1
Loop While (LNG_resultat = 0)
get_values = LNG_index - 1
End Function
Public Function get_subkeys(Base_key As Long, Optional retour As Variant) As Long
' Cette fonction remplie la variable de retour avec les sous-clé directement
' liées à celle dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
' ou d'une des constente prédéfinie
' VBREG_HKEY_CLASSES_ROOT,VBREG_HKEY_CURRENT_USER,VBREG_HKEY_CURRENT_USER
' VBREG_HKEY_USERS,VBREG_HKEY_CURRENT_CONFIG,VBREG_HKEY_DYN_DATA
'
' retour as variant est optionnel vous pouvez y passer
' une collection, une listbox, une combo box, ou un
' tableau de chaine vide
' si vous ne l'utilisez pas, la fonction retournera
' seulement le nombre de sous-clé files
'-----------------------------------------------------------------------------
' retourne le nombre de sous-clé fille sur un long
'-----------------------------------------------------------------------------
Dim LNG_index As Long
Dim STR_name As String
Dim STR_keyname As String
Dim STR_type As String
Dim LNG_resultat As Long
Dim LNG_len As Long
Dim LNG_cnt1 As Long
LNG_cnt1 = 0
STR_name = String(513, Chr$(0))
STR_type = TypeName(retour)
LNG_index = 0
Do
LNG_resultat = RegEnumKey(Base_key, LNG_index, ByVal STR_name, 512)
If LNG_resultat = 0 And STR_type <> "Error" Then
LNG_len = InStr(1, STR_name, Chr$(0)) If LNG_len >2 Then STR_keyname Left$(STR_name, LNG_len - 1)
If STR_type = "Collection" Then retour.Add Item:=STR_keyname
If STR_type = "ListBox" Then retour.AddItem STR_keyname
If STR_type = "ComboBox" Then retour.AddItem STR_keyname
If STR_type = "String()" Then
ReDim Preserve retour(LNG_cnt1) As String
retour(LNG_cnt1) = STR_keyname
LNG_cnt1 = LNG_cnt1 + 1
End If
End If
LNG_index = LNG_index + 1
Loop While (LNG_resultat = 0)
get_subkeys = LNG_index - 1
End Function
Public Function create_a_value(Base_key As Long, value_type As Long, value_name As String, value_data As Variant) As Long
' cette fonction créera une donnée fille de la clé dont vous fournissez
' le handle d'ouverture
'-----------------------------------------------------------------------------
' param : key as long provenant d'une précédente ouverture
'
' value_type as long une des constente prédéfie
' VBREG_REG_NONE,VBREG_REG_NONE,VBREG_REG_EXPAND_SZ,VBREG_REG_BINARY,VBREG_REG_DWORD
' VBREG_REG_DWORD_BIG_ENDIAN,VBREG_REG_LINK,VBREG_REG_MULTI_SZ
' VBREG_REG_RESOURCE_LIST,VBREG_REG_FULL_RESOURCE_DESCRIPTOR
' VBREG_REG_RESOURCE_REQUIREMENTS_LIST
'
' value_name as string chaine de caractaires représentant le nom
' que vous voulez donner à votre donnée fille
'
' value_data as variant vous pouvez y passer :
' un tableau de d'octet 'Byte()'
' un tableau de cahine 'String()'
' un 'String'
' un 'Long'
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
' fonctionnement :
' un value_data donné en tant que Byte() sera transformé en un String et
' repassera dans la moulinette
' un value_data donné en tant que String() ne pourra être utilisé uniquement
' avec un value_type REG_MULTY_SZ. le value_type sera automatiquement changé
' en REG_MULTY_SZ
' un value_data String ou Byte() utilisé avec un value_type VBREG_REG_DWORD écrira un
' DWORD équivalent à la chaine de caractaires par VAL()
'-----------------------------------------------------------------------------
Dim STR_type As String
Dim STR_value As String
Dim LNG_value As Long
Dim BLN_cont As Boolean
Dim LNG_resultat As Long
STR_value "": LNG_value 0
STR_type = TypeName(value_data)
Do
BLN_cont = False
Select Case STR_type
Case "Byte()"
STR_value = tbyte_to_string(value_data)
STR_type = "String"
BLN_cont = True
Case "String()"
STR_value = tstring_to_string(value_data)
value_type = VBREG_REG_MULTI_SZ
STR_type = "String"
BLN_cont = True
Case "String"
STR_value = value_data
If value_type = VBREG_REG_MULTI_SZ Then
STR_value = Replace(STR_value, Chr$(13) + Chr$(10), Chr$(0)) + Chr$(0)
If Right$(STR_value, 2) <> Chr$(0) + Chr$(0) Then STR_value = STR_value + Chr$(0)
End If
If value_type = VBREG_REG_DWORD Then
LNG_value = Val(STR_value)
STR_type = "Long"
Else
End If
Case "Long"
LNG_value = value_data
End Select
Loop While BLN_cont
If STR_type = "Long" Then
LNG_resultat = RegSetValueEx(Base_key, value_name, 0&, VBREG_REG_DWORD, LNG_value, 4)
create_a_value = LNG_resultat
Else
LNG_resultat = RegSetValueEx(Base_key, value_name, 0&, value_type, ByVal STR_value, Len(STR_value))
create_a_value = LNG_resultat
End If
End Function
Public Function read_a_value(Base_key As Long, value_name As String, Optional value_type As Long) As Variant
' cette fonction retournera la donnée contenue par la valeur fille de la clé
' dont vous fournissez le handle d'ouverture
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
' value_name as string chaine de caractaires représentant le nom
' de la valeur dont vous voulez récupérer la
' donnée
'
' value_type as long est un paramètre optionel dans lequel sera
' stoqué le type de donnée contenu
'-----------------------------------------------------------------------------
' retourne le contenue dans une variable de type variante
'-----------------------------------------------------------------------------
Dim STR_value As String
Dim LNG_value As Long
Dim LNG_lenbuffer As Long
Dim LNG_resultat As Long
Dim LNG_type As Long
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, LNG_type, 0&, LNG_lenbuffer)
value_type = LNG_type
If LNG_type = VBREG_REG_DWORD Then
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, VBREG_REG_DWORD, LNG_value, 4)
read_a_value = LNG_value
Else
STR_value = String(LNG_lenbuffer, Chr$(0))
LNG_resultat = RegQueryValueEx(Base_key, value_name, 0&, LNG_type, ByVal STR_value, LNG_lenbuffer) If LNG_type VBREG_REG_SZ Then STR_value Left$(STR_value, Len(STR_value) - 1)
If LNG_type = VBREG_REG_MULTI_SZ Then
STR_value = Left$(STR_value, Len(STR_value) - 2)
STR_value = Replace(STR_value, Chr$(0), Chr$(13) + Chr$(10))
End If
read_a_value = STR_value
End If
End Function
Public Function delete_all_values(Base_key As Long) As Long
' cette fonction détruiera les valeurs contenues dans une clé
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
'-----------------------------------------------------------------------------
' retourne le nombre de valeurs détruites
'-----------------------------------------------------------------------------
Dim ARY_valeur() As valeur
Dim LNG_nbvaleur As Long
Dim LNG_resultat As Long
Dim LNG_cnt As Long
LNG_nbvaleur = get_values(Base_key, ARY_valeur)
For LNG_cnt = 0 To LNG_nbvaleur - 1
LNG_resultat = delete_a_value(Base_key, ARY_valeur(LNG_cnt).nom)
Next LNG_cnt
End Function
Public Function delete_a_value(Base_key As Long, value_name As String) As Long
' cette fonction détruiera la valeur dont vous donné le handel d'ouverture de
' la clé parente
'-----------------------------------------------------------------------------
' param : Base_Key as long provenant d'une précédente ouverture
'
' value_name as string chaine de caractaires représentant le nom
' de la valeur que vous voulez détruire
'-----------------------------------------------------------------------------
' retourne le résultat sur un long
'-----------------------------------------------------------------------------
delete_a_value = RegDeleteValue(Base_key, ByVal value_name)
End Function
Public Sub save_a_reg_file(Base_key As String, file_name As String)
' cette procédure sauvegardera la clé mére dont vous founirez le chemin
' dans un fichier de type REG
'-----------------------------------------------------------------------------
' param : Base_Key as string contient le chemin de la clé à sauvegarder
' EX : "VBREG_HKEY_LOCAL_MACHINE\SOFTWARE\test"
'
' file_name as string contien le du fichier de sauvegarde
'-----------------------------------------------------------------------------
Dim INT_filehandel As Integer
Dim STR_hkey As String
Dim STR_subkey As String
Dim STR_parentkey As String
Dim STR_tampo As String
Dim LNG_key As Long
Dim LNG_resultat As Long
STR_tampo = "[" + Base_key + "]"
STR_hkey = get_hkey(STR_tampo)
STR_subkey = get_subkey(STR_tampo)
STR_parentkey = STR_tampo
LNG_key = open_a_key(STR_hkey, STR_parentkey + "" + STR_subkey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
Exit Sub
End If
INT_filehandel = FreeFile
Open file_name For Output As #INT_filehandel
Print #INT_filehandel, "REGEDIT4"
Print #INT_filehandel, "[" + Base_key + "]"
Call save_the_values(LNG_key, INT_filehandel)
Call save_the_keys(LNG_key, Base_key, INT_filehandel)
Close #INT_filehandel
LNG_resultat = close_a_key(LNG_key)
End Sub
Private Sub save_the_keys(Base_key As Long, basekey_name As String, file_handel As Integer)
Dim LNG_resultat As Long
Dim LNG_key As Long
Dim STR_keyname As String
Dim LNG_pos As Long
Dim LNG_index As Long
Do
STR_keyname = String(513, Chr$(0))
LNG_resultat = RegEnumKey(Base_key, LNG_index, ByVal STR_keyname, 512)
If LNG_resultat <> 0 Then
Exit Do
Else
LNG_pos = InStr(1, STR_keyname, Chr$(0)) If LNG_pos >2 Then STR_keyname Left$(STR_keyname, LNG_pos - 1)
Print #file_handel, "[" + basekey_name + "" + STR_keyname + "]"
LNG_key = open_a_key(Base_key, STR_keyname, VBREG_KEY_ALL_ACCESS, LNG_resultat)
Call save_the_values(LNG_key, file_handel)
Call save_the_keys(LNG_key, basekey_name + "" + STR_keyname, file_handel)
LNG_resultat = close_a_key(LNG_key)
End If
LNG_index = LNG_index + 1
Loop
End Sub
Private Sub save_the_values(Base_key As Long, file_handel As Integer)
Dim ARY_valeurs() As valeur
Dim LNG_nbvaleurs As Long
Dim STR_linetowrite As String
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim VRT_cnt3 As Variant
LNG_nbvaleurs = get_values(Base_key, ARY_valeurs)
For LNG_cnt1 = 0 To LNG_nbvaleurs - 1
If ARY_valeurs(LNG_cnt1).nom = "" Then
STR_linetowrite = "@="
Else
STR_linetowrite = Chr$(34) + ARY_valeurs(LNG_cnt1).nom + Chr$(34) + "="
End If
Select Case ARY_valeurs(LNG_cnt1).type
Case VBREG_REG_SZ
STR_linetowrite = STR_linetowrite + Chr$(34) + tbyte_to_string(ARY_valeurs(LNG_cnt1).data)
STR_linetowrite = Left$(STR_linetowrite, Len(STR_linetowrite) - 1) + Chr$(34)
Case VBREG_REG_DWORD
STR_linetowrite = STR_linetowrite + "dword:"
For LNG_cnt2 = 3 To 0 Step -1
STR_linetowrite = STR_linetowrite + Hex$(ARY_valeurs(LNG_cnt1).data(LNG_cnt2))
Next LNG_cnt2
Case Else
STR_linetowrite = STR_linetowrite + "hex(" + Trim$(Hex$(ARY_valeurs(LNG_cnt1).type)) + "):"
For Each VRT_cnt3 In ARY_valeurs(LNG_cnt1).data
STR_linetowrite = STR_linetowrite + Trim$(Hex$(VRT_cnt3)) + ","
Next VRT_cnt3
STR_linetowrite = Left$(STR_linetowrite, Len(STR_linetowrite) - 1)
End Select
Print #file_handel, STR_linetowrite
Next LNG_cnt1
End Sub
Public Sub restore_a_reg_file(file_name As String)
' cette procédure détruira la clé mére contenue dans lefichier REG
' et fera la restoration de celui-ci
'-----------------------------------------------------------------------------
Dim BYT_car1 As Byte
Dim BYT_car2 As Byte
Dim STR_tempo1 As String
Dim STR_tempo2 As String
Dim LNG_linetype As Long
Dim LNG_key1 As Long
Dim LNG_key2 As Long
Dim STR_hkey As String
Dim STR_subkey As String
Dim STR_parentkey As String
Dim STR_valuename As String
Dim LNG_resultat As Long
Dim INT_filehandel As Integer
Dim BYT_finligne As Byte
Dim LNG_debutpath As Long
Dim LNG_finpath As Long
BYT_finligne 0: BYT_car1 0: BYT_car2 = 0
INT_filehandel = FreeFile
Open file_name For Binary As INT_filehandel
While (Not EOF(INT_filehandel))
Get #INT_filehandel, , BYT_car1
If BYT_finligne = 1 And BYT_car1 <> 34 And BYT_car1 <> 64 And BYT_car1 <> 91 And (Not EOF(INT_filehandel)) Then
BYT_finligne = 0
End If If BYT_finligne 1 And (BYT_car1 34 Or BYT_car1 = 64 Or BYT_car1 = 91 Or EOF(INT_filehandel)) Then
BYT_finligne = 2
LNG_linetype = 0
STR_tempo1 = Mid$(STR_tempo2, 1, 1) If STR_tempo1 "[" Then LNG_linetype 1 If STR_tempo1 Chr$(34) Or STR_tempo1 "@" Then LNG_linetype = 2
If LNG_linetype = 1 Then
LNG_debutpath = InStr(STR_tempo2, "[")
LNG_finpath = InStr(STR_tempo2, "]")
STR_tempo2 = Mid$(STR_tempo2, LNG_debutpath, LNG_finpath - LNG_debutpath + 1)
End If
If LNG_linetype = 2 Then
STR_tempo1 = Right$(STR_tempo2, 2) While (STR_tempo1 Chr$(13) + Chr$(10) Or STR_tempo1 Chr$(10) + Chr$(13))
STR_tempo2 = Left$(STR_tempo2, Len(STR_tempo2) - 2)
STR_tempo1 = Right$(STR_tempo2, 2)
Wend
End If
End If If (BYT_car1 13 And BYT_car2 10) Or (BYT_car1 = 10 And BYT_car2 = 13) Then
BYT_finligne = 1
End If
If BYT_finligne = 2 Then
If LNG_linetype = 1 Then
LNG_resultat = close_a_key(LNG_key1)
STR_hkey = get_hkey(STR_tempo2)
STR_subkey = get_subkey(STR_tempo2)
STR_parentkey = STR_tempo2
LNG_key1 = open_a_key(STR_hkey, STR_parentkey, VBREG_KEY_ALL_ACCESS, LNG_resultat)
LNG_resultat = delete_a_key(LNG_key1, STR_subkey)
LNG_key1 = create_a_key(STR_hkey, STR_parentkey + "" + STR_subkey, LNG_resultat)
End If
If LNG_linetype = 2 Then
STR_valuename = get_value_name(STR_tempo2)
LNG_linetype = get_value_type(STR_tempo2)
LNG_resultat = create_a_value(LNG_key1, LNG_linetype, STR_valuename, STR_tempo2)
End If
STR_tempo2 = Chr$(BYT_car1)
BYT_finligne = 0
Else
STR_tempo2 = STR_tempo2 + Chr$(BYT_car1)
BYT_car2 = BYT_car1
End If
Wend
Close INT_filehandel
End Sub
Private Function get_hkey(key_path As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(key_path)
For LNG_cnt = 1 To LNG_len
STR_car = Mid$(key_path, LNG_cnt, 1)
If STR_car <> "[" And STR_car <> "" Then
STR_tempo = STR_tempo + STR_car
End If
If STR_car = "" Then
key_path = Right$(key_path, LNG_len - LNG_cnt)
key_path = Left$(key_path, Len(key_path) - 1)
Exit For
End If
Next LNG_cnt
get_hkey = STR_tempo
End Function
Private Function get_subkey(key_path As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(key_path)
For LNG_cnt = LNG_len To 1 Step -1
STR_car = Mid$(key_path, LNG_cnt, 1)
If STR_car = "" Then
STR_tempo = Right$(key_path, Len(key_path) - LNG_cnt)
key_path = Left$(key_path, LNG_cnt - 1)
Exit For
End If
Next LNG_cnt
get_subkey = STR_tempo
End Function
Private Function get_value_name(value_line As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim LNG_cnt As Long
Dim STR_car As String
LNG_len = Len(value_line)
If Mid$(value_line, 1, 1) = "@" Then
get_value_name = ""
value_line = Mid$(value_line, 3, LNG_len - 2)
Exit Function
End If
For LNG_cnt = 1 To LNG_len
STR_car = Mid$(value_line, LNG_cnt, 1)
If STR_car <> Chr$(34) And STR_car <> "=" Then
STR_tempo = STR_tempo + STR_car
End If
If STR_car = "=" Then
value_line = Right$(value_line, LNG_len - LNG_cnt)
Exit For
End If
Next LNG_cnt
get_value_name = STR_tempo
End Function
Private Function get_value_type(value_line As String) As Long
Dim LNG_len As Long
Dim STR_tempo1 As String
Dim STR_tempo2 As String
Dim STR_tempo3 As String
Dim STR_tempo4 As String
Dim STR_tempo5 As String
LNG_len = Len(value_line)
STR_tempo1 = Mid$(value_line, 1, 1)
STR_tempo2 = Mid$(value_line, 1, 4)
STR_tempo3 = Mid$(value_line, 1, 3)
STR_tempo4 = Mid$(value_line, 1, 5)
STR_tempo5 = Mid$(value_line, 5, 1)
If STR_tempo3 "hex" And STR_tempo2 <> "hex(" Then STR_tempo2 "hex(": STR_tempo5 = "3"
If STR_tempo1 = Chr$(34) Then
get_value_type = VBREG_REG_SZ
value_line = Mid$(value_line, 2, LNG_len - 2)
Exit Function
End If
If STR_tempo2 = "hex(" Then
get_value_type = Val("&H" + STR_tempo5)
value_line = Right$(value_line, LNG_len - 7) If get_value_type 7 Then value_line Left$(value_line, Len(value_line) - 1)
value_line = get_value_BI(value_line)
Exit Function
End If If STR_tempo4 "dword" Or STR_tempo4 "DWORD" Then
get_value_type = VBREG_REG_DWORD
value_line = Right$(value_line, LNG_len - 6)
value_line = Str$(Val("&H" + value_line))
Exit Function
End If
get_value_type = 0
End Function
Private Function get_value_BI(value_line As String) As String
Dim STR_tempo As String
Dim LNG_len As Long
Dim STR_car As String
Dim LNG_cnt As Long
value_line = Replace(value_line, ",", "")
LNG_len = Len(value_line)
For LNG_cnt = 1 To LNG_len Step 2
STR_car = Mid$(value_line, LNG_cnt, 2)
STR_tempo = STR_tempo + Chr$(Val("&H" + STR_car))
Next LNG_cnt
get_value_BI = STR_tempo
End Function
Public Sub delete_association(Ext_name As String)
' cette procédure détruira une association entre un type de fichier et une
' application
'-----------------------------------------------------------------------------
' param : Ext_name as string extention de votre type de fichier
' EX=".xxx"
'-----------------------------------------------------------------------------
Dim LNG_key As Long
Dim LNG_resultat As Long
Dim STR_tempo As String
LNG_key = open_a_key(VBREG_HKEY_CLASSES_ROOT, Ext_name, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then
LNG_key = open_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + Ext_name, VBREG_KEY_ALL_ACCESS, LNG_resultat)
If LNG_resultat <> 0 Then Exit Sub
End If
STR_tempo = read_a_value(LNG_key, "")
LNG_resultat = close_a_key(LNG_key)
LNG_key = open_a_key(VBREG_HKEY_CLASSES_ROOT, "", VBREG_KEY_ALL_ACCESS)
LNG_resultat = delete_a_key(LNG_key, Ext_name)
LNG_resultat = delete_a_key(LNG_key, STR_tempo)
LNG_resultat = close_a_key(LNG_key)
LNG_key = open_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes", VBREG_KEY_ALL_ACCESS)
LNG_resultat = delete_a_key(LNG_key, Ext_name)
LNG_resultat = delete_a_key(LNG_key, STR_tempo)
close_a_key (LNG_key)
End Sub
Public Sub create_association(Ext_name As String, App_name As String, Cmd_lines As Variant, Icone As String, Comment As String, Options As Long)
' cette procédure créera une association entre un type de fichier et une
' application
'-----------------------------------------------------------------------------
' param : Ext_name as string extention de votre type de fichier
' EX=".xxx"
'
' App_name as string nom de votre programme
'
' Cmd_line as variant contient un tableau de string
' var(0,n)=nom de l'action
' var(1,n)=command à exécuter
'
' Icone as string contient le fichier .ico de l'icone
' représentant votre type de fichiers
'
' Comment as string ligne de commantaire qui sera incluse
' le gestionnaire des extentions (dans
' les option d'affichage d'un explorateur)
'
' Options as long option possible pour la création de
' votre association=
' VBREG_QUICKVIEW= autorise le quickview
' VBREG_SHOWEXT= oblige à montrer l'extention
'-----------------------------------------------------------------------------
Dim STR_filetype As String
Dim LNG_resultat As Long
Dim LNG_key As Long
Dim STR_type As String
Dim STR_shellname As String
Dim STR_shellcommand As String
Dim BLN_quickview As Boolean
Dim BLN_showext As Boolean
Dim LNG_cnt As Long
If Options And VBREG_QUICKVIEW VBREG_QUICKVIEW Then BLN_quickview True If Options And VBREG_SHOWEXT VBREG_SHOWEXT Then BLN_showext True
STR_type = TypeName(Cmd_lines)
If STR_type <> "String()" Then Exit Sub
STR_filetype = App_name + " files"
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, Ext_name)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_filetype)
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Comment)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_BINARY, "EditFlags", Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)) If BLN_showext True Then LNG_resultat create_a_value(LNG_key, VBREG_REG_BINARY, "AlwaysShowExt", "")
LNG_key = create_a_key(LNG_key, "DefaultIcon")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Icone)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + Ext_name)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_filetype)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Comment)
LNG_resultat = create_a_value(LNG_key, VBREG_REG_BINARY, "EditFlags", Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0)) If BLN_showext True Then LNG_resultat create_a_value(LNG_key, VBREG_REG_BINARY, "AlwaysShowExt", "")
LNG_key = create_a_key(LNG_key, "DefaultIcon")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", Icone)
If BLN_quickview = True Then
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_key = create_a_key(LNG_key, "BLN_quickview")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", "*")
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_key = create_a_key(LNG_key, "BLN_quickview")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", "*")
End If
On Error GoTo fin_boucle
While (True)
STR_shellname = Cmd_lines(0, LNG_cnt)
STR_shellcommand = Cmd_lines(1, LNG_cnt)
If STR_shellname <> "" And STR_shellcommand <> "" Then
LNG_key = create_a_key(VBREG_HKEY_CLASSES_ROOT, STR_filetype)
LNG_key = create_a_key(LNG_key, "shell" + STR_shellname + "\command")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_shellcommand)
LNG_key = create_a_key(VBREG_HKEY_LOCAL_MACHINE, "SOFTWARE\Classes" + STR_filetype)
LNG_key = create_a_key(LNG_key, "shell" + STR_shellname + "\command")
LNG_resultat = create_a_value(LNG_key, VBREG_REG_SZ, "", STR_shellcommand)
End If
LNG_cnt = LNG_cnt + 1
Wend
fin_boucle:
On Error GoTo 0
End Sub
Private Function tbyte_to_string(byte_array As Variant) As String
Dim VRT_cnt As Variant
For Each VRT_cnt In byte_array
tbyte_to_string = tbyte_to_string + Chr$(VRT_cnt)
Next VRT_cnt
End Function
Private Function tstring_to_string(string_array As Variant) As String
Dim VRT_cnt As Variant
For Each VRT_cnt In string_array
If VRT_cnt <> "" Then tstring_to_string = tstring_to_string + VRT_cnt + Chr$(0)
Next VRT_cnt
tstring_to_string = tstring_to_string + Chr$(0)
End Function
Private Function string_to_tstring(a_string As String) As String()
Dim LNG_len As Long
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim STR_retour() As String
Dim STR_car As String
Dim STR_mot As String
LNG_cnt2 = 0
LNG_len = Len(a_string)
For LNG_cnt1 = 1 To LNG_len
STR_car = Mid$(a_string, LNG_cnt1, 1)
If STR_car = Chr$(0) Then
If STR_mot <> "" Then
ReDim Preserve STR_retour(LNG_cnt2) As String
STR_retour(LNG_cnt2) = STR_mot
LNG_cnt2 = LNG_cnt2 + 1
End If
STR_mot = ""
Else
STR_mot = STR_mot + STR_car
End If
Next LNG_cnt1
string_to_tstring = STR_retour
End Function
Private Function string_to_tbyte(a_string As String) As Byte()
Dim LNG_len As Long
Dim LNG_cnt1 As Long
Dim LNG_cnt2 As Long
Dim BYT_retour() As Byte
Dim STR_car As String
LNG_cnt2 = 0
LNG_len = Len(a_string)
For LNG_cnt1 = 1 To LNG_len
STR_car = Mid$(a_string, LNG_cnt1, 1)
ReDim Preserve BYT_retour(LNG_cnt2) As Byte
BYT_retour(LNG_cnt2) = Asc(STR_car)
LNG_cnt2 = LNG_cnt2 + 1
Next LNG_cnt1
string_to_tbyte = BYT_retour
End Function
[FormVB]############################################################################
VERSION 5.00
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form Reg
Caption = "Accès Base de Registre"
ClientHeight = 6105
ClientLeft = 2685
ClientTop = 2460
ClientWidth = 9120
LinkTopic = "Form2"
ScaleHeight = 6105
ScaleWidth = 9120
Begin VB.CommandButton Command2
Caption = "Quitter"
Height = 495
Left = 7080
TabIndex = 24
Top = 5520
Width = 1935
End
Begin TabDlg.SSTab SSTab1
Height = 5295
Left = 120
TabIndex = 0
Top = 120
Width = 8895
_ExtentX = 15690
_ExtentY = 9340
_Version = 393216
Style = 1
Tabs = 2
TabHeight = 520
ShowFocusRect = 0 'False
TabCaption(0) = "Définition de Clés"
TabPicture(0) = "Reg.frx":0000
Tab(0).ControlEnabled= -1 'True
Tab(0).Control(0)= "hkey_box"
Tab(0).Control(0).Enabled= 0 'False
Tab(0).Control(1)= "subkey_box"
Tab(0).Control(1).Enabled= 0 'False
Tab(0).Control(2)= "keyaction_box"
Tab(0).Control(2).Enabled= 0 'False
Tab(0).Control(3)= "dst"
Tab(0).Control(3).Enabled= 0 'False
Tab(0).Control(4)= "remote"
Tab(0).Control(4).Enabled= 0 'False
Tab(0).ControlCount= 5
TabCaption(1) = "Définition de valeur"
TabPicture(1) = "Reg.frx":001C
Tab(1).ControlEnabled= 0 'False
Tab(1).Control(0)= "value_box"
Tab(1).Control(1)= "valueaction_box"
Tab(1).ControlCount= 2
Begin VB.CheckBox remote
Caption = "BDR Distant"
Height = 375
Left = 240
TabIndex = 44
Top = 4200
Width = 1575
End
Begin VB.TextBox dst
Height = 285
Left = 240
TabIndex = 43
Top = 3840
Width = 2655
End
Begin VB.Frame keyaction_box
Caption = "Actions"
Height = 1215
Left = 3120
TabIndex = 28
Top = 3240
Width = 5655
Begin VB.CommandButton key_exe
Cancel = -1 'True
Caption = "Exécute"
Height = 255
Left = 4440
TabIndex = 36
Top = 480
Width = 1095
End
Begin VB.TextBox key_to_creat
Height = 285
Left = 1800
TabIndex = 35
Top = 480
Width = 2535
End
Begin VB.OptionButton sup_key
Caption = "Efface la sous-clé"
Height = 255
Left = 120
TabIndex = 30
Top = 720
Width = 1695
End
Begin VB.OptionButton creat_key
Caption = "Créer la sous-clé"
Height = 255
Left = 120
TabIndex = 29
Top = 360
Width = 1695
End
End
Begin VB.Frame valueaction_box
Caption = "Actions"
Height = 1455
Left = -74880
TabIndex = 25
Top = 3720
Width = 8535
Begin VB.CommandButton value_exe
Caption = "Execute action"
Height = 615
Left = 2640
TabIndex = 40
Top = 480
Width = 2415
End
Begin VB.OptionButton sup_val
Caption = "Lit ou efface une valeur"
Height = 375
Left = 120
TabIndex = 27
Top = 840
Width = 2295
End
Begin VB.OptionButton creat_val
Caption = "Fixe ou créé une valeur"
Height = 375
Left = 120
TabIndex = 26
Top = 240
Width = 3855
End
End
Begin VB.Frame value_box
Caption = "Valeur de la sous clé"
Height = 3015
Left = -74880
TabIndex = 9
Top = 600
Width = 8535
Begin VB.ListBox value_name
Height = 1230
Left = 4080
TabIndex = 38
Top = 480
Width = 4335
End
Begin VB.OptionButton value_type
Caption = "REG_NONE"
Height = 255
Index = 0
Left = 120
TabIndex = 21
Top = 240
Width = 1215
End
Begin VB.OptionButton value_type
Caption = "REG_SZ"
Height = 255
Index = 1
Left = 120
TabIndex = 20
Top = 480
Width = 975
End
Begin VB.OptionButton value_type
Caption = "REG_EXPAND_SZ"
Height = 255
Index = 2
Left = 120
TabIndex = 19
Top = 720
Width = 1815
End
Begin VB.OptionButton value_type
Caption = "REG_BINARY"
Height = 255
Index = 3
Left = 120
TabIndex = 18
Top = 960
Width = 1335
End
Begin VB.OptionButton value_type
Caption = "REG_DWORD"
Height = 255
Index = 4
Left = 120
TabIndex = 17
Top = 1200
Width = 1455
End
Begin VB.OptionButton value_type
Caption = "REG_DWORD_BIG_ENDIAN (do not use)"
Height = 255
Index = 5
Left = 120
TabIndex = 16
Top = 1440
Width = 3375
End
Begin VB.OptionButton value_type
Caption = "REG_LINK (do not use)"
Height = 255
Index = 6
Left = 120
TabIndex = 15
Top = 1680
Width = 2055
End
Begin VB.OptionButton value_type
Caption = "REG_MULTI_SZ"
Height = 255
Index = 7
Left = 120
TabIndex = 14
Top = 1920
Width = 1575
End
Begin VB.OptionButton value_type
Caption = "REG_RESOURCE_LIST"
Height = 255
Index = 8
Left = 120
TabIndex = 13
Top = 2160
Width = 2295
End
Begin VB.OptionButton value_type
Caption = "REG_FULL_RESOURCE_DESCRIPTOR"
Height = 255
Index = 9
Left = 120
TabIndex = 12
Top = 2400
Width = 3375
End
Begin VB.OptionButton value_type
Caption = "REG_RESOURCE_REQUIREMENTS_LIST"
Height = 255
Index = 10
Left = 120
TabIndex = 11
Top = 2640
Width = 3495
End
Begin VB.TextBox value_multi_sz
Height = 1005
Left = 4080
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex
zeunz
Messages postés
200
Date d'inscription
jeudi 26 février 2004
Statut
Membre
Dernière intervention
30 juin 2008
15 août 2004 à 00:19
15 août 2004 à 00:19
bonjour. ya bcp plus simple! voic qques fonction ce verification de l'existence de clef, de lecture, de creation et de destruction de clef.
il y a aussi des propriete dans vb (ca dot etre save setting je crois)
bonne prog.
zeunz.
Public Function VerifKeyRegedit(Cle As String, Optional Section As String) As Boolean
'***********************************************************
' Fonction de vérification de l'existence d'ue clé *
'***********************************************************
'Déclaration des variables
Dim Wshshell
Dim Key As String
'Initialisation de la fonction
VerifKeyRegedit = True
'Gestion des erreurs
On Error GoTo Erreur
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Lecture de la clé
Key = Wshshell.regread(Cle & "" & Section)
'Fin de la fonction
Exit Function
'Traitement des erreurs
Erreur:
'Initialisation de la fonction
VerifKeyRegedit = False
End Function
Public Sub CreateKeyRegedit(Cle As String, Section As String, Valeur As String)
'*****************************************************************************
' Procédure de création de clé et de valeur dans la base de registre *
'*****************************************************************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Création de la clé
Wshshell.regwrite Cle & "" & Section, Valeur, "REG_SZ"
End Sub
(cle="hKey user" par exemple
section=les clefs sous adjacentes)
Public Function ReadKeyRegedit(Cle As String, Section As String)
'*****************************************************************************
' Procédure de lecture de clé et de valeur dans la base de registre *
'*****************************************************************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Lecture de la clé
ReadKeyRegedit = Wshshell.regread(Cle & "" & Section)
End Function
Public Sub DeleteKeyRegedit(Cle As String, Optional Section As String)
'*****************************
' Destruction d'une clef
'*****************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Création de la clé
Wshshell.regdelete Cle & "" & Section
End Sub
il y a aussi des propriete dans vb (ca dot etre save setting je crois)
bonne prog.
zeunz.
Public Function VerifKeyRegedit(Cle As String, Optional Section As String) As Boolean
'***********************************************************
' Fonction de vérification de l'existence d'ue clé *
'***********************************************************
'Déclaration des variables
Dim Wshshell
Dim Key As String
'Initialisation de la fonction
VerifKeyRegedit = True
'Gestion des erreurs
On Error GoTo Erreur
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Lecture de la clé
Key = Wshshell.regread(Cle & "" & Section)
'Fin de la fonction
Exit Function
'Traitement des erreurs
Erreur:
'Initialisation de la fonction
VerifKeyRegedit = False
End Function
Public Sub CreateKeyRegedit(Cle As String, Section As String, Valeur As String)
'*****************************************************************************
' Procédure de création de clé et de valeur dans la base de registre *
'*****************************************************************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Création de la clé
Wshshell.regwrite Cle & "" & Section, Valeur, "REG_SZ"
End Sub
(cle="hKey user" par exemple
section=les clefs sous adjacentes)
Public Function ReadKeyRegedit(Cle As String, Section As String)
'*****************************************************************************
' Procédure de lecture de clé et de valeur dans la base de registre *
'*****************************************************************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Lecture de la clé
ReadKeyRegedit = Wshshell.regread(Cle & "" & Section)
End Function
Public Sub DeleteKeyRegedit(Cle As String, Optional Section As String)
'*****************************
' Destruction d'une clef
'*****************************
'Déclaration des variables
Dim Wshshell
'Appel de la référence
Set Wshshell = CreateObject("WScript.Shell")
'Création de la clé
Wshshell.regdelete Cle & "" & Section
End Sub