5/5 (16 avis)
Vue 6 485 fois - Téléchargée 522 fois
Option Explicit ' 'La plupart de ces fonctions sont 'faites sur base des Exemples du site AllApi.net ' Dim cnt As Integer Dim Program Dim IniList(1 To 6) As Collection Dim VeriF(1 To 6) Dim SearchStr Dim Path Dim Chm Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long Dim Sa(1 To 5) Dim Sb(1 To 5) '/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/ ' Pour les fonctions du registre Const HKLM = &H80000002 Const HKCU = &H80000001 Const REG_OPTION_BACKUP_RESTORE = 4 Const REG_OPTION_VOLATILE = 1 Const REG_OPTION_NON_VOLATILE = 0 Const STANDARD_RIGHTS_ALL = &H1F0000 Const SYNCHRONIZE = &H100000 Const READ_CONTROL = &H20000 Const STANDARD_RIGHTS_READ = (READ_CONTROL) Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) Const KEY_CREATE_LINK = &H20 Const KEY_CREATE_SUB_KEY = &H4 Const KEY_ENUMERATE_SUB_KEYS = &H8 Const KEY_NOTIFY = &H10 Const KEY_QUERY_VALUE = &H1 Const KEY_SET_VALUE = &H2 Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) Const KEY_EXECUTE = (KEY_READ) Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) Const REG_SZ = 1 Const ERROR_NO_MORE_ITEMS = 259& Const HKEY_CURRENT_CONFIG = &H80000005 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal samDesired As Long, phkResult As Long) 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 RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult 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 Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) 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 '-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/ '-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/ 'Pour le dossier de demarrage ' '(SystemDrive\Documents and Settings\UserName\Menu Demarrer\Demarrage\) Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Const MAX_PATH = 260 Const MAXDWORD = &HFFFF Const INVALID_HANDLE_VALUE = -1 Const FILE_ATTRIBUTE_ARCHIVE = &H20 Const FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_HIDDEN = &H2 Const FILE_ATTRIBUTE_NORMAL = &H80 Const FILE_ATTRIBUTE_READONLY = &H1 Const FILE_ATTRIBUTE_SYSTEM = &H4 Const FILE_ATTRIBUTE_TEMPORARY = &H100 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type 'renvoi le path du dossier run Private Function GetPath() Dim strUserName As String Dim sSave As String, Ret As Long Dim disk, user sSave = Space(255) Ret = GetSystemDirectory(sSave, 255) sSave = Left$(sSave, Ret) disk = Left(sSave, 3) strUserName = String(100, Chr$(0)) GetUserName strUserName, 100 strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1) user = strUserName ' & Chr$(13) GetPath = disk & "Documents and Settings\" & user & "\Menu Démarrer\Programmes\Démarrage\" End Function 'function pour interroger la bdr Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String On Error Resume Next Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) If lResult = 0 Then strBuf = String(lDataBufSize, Chr$(0)) lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) If lResult = 0 Then RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1) End If End If End Function 'lire une valeur Function ReadValue(hKey As Long, strPath As String, strValue As String) On Error Resume Next Dim Ret RegOpenKey hKey, strPath, Ret ReadValue = RegQueryStringValue(Ret, strValue) RegCloseKey Ret End Function 'ecrire une valeur Sub RegWrite(hKey As Long, strPath As String, strValue As String, strData As String) On Error Resume Next Dim Ret RegCreateKey hKey, strPath, Ret RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData) RegCloseKey Ret End Sub 'supprimer une valeur du registre Private Function DeleteValue(ByVal hKey, ByVal Section As String, ByVal Key As String) Dim KeyValue As Long Call RegOpenKey(hKey, Section, KeyValue) '// Ouverture Call RegDeleteValue(KeyValue, Key) '// Supprime la valeur Call RegCloseKey(KeyValue) '// Fermeture End Function 'Fonction pour verifier l'existence d'une cle Public Function CleExist(Rac, Cle As String) As Boolean Dim Result As Long RegOpenKeyEx Rac, Cle, 0, KEY_ALL_ACCESS, Result If Result = 0 Then CleExist = False Else CleExist = True RegCloseKey Result End Function 'enumerer les valeurs d'une clef Public Function GetKeyNumber(Racine, Cle, NbrLst, Action) '1 Dim ii, VeriFic Dim hKey As Long, NbCl As Integer, sName As String, sData As String, Ret As Long, RetData As Long Const BUFFER_SIZE As Long = 255 If RegOpenKey(Racine, Cle, hKey) = 0 Then sName = Space(BUFFER_SIZE) sData = Space(BUFFER_SIZE) Ret = BUFFER_SIZE RetData = BUFFER_SIZE 'enumeration des cles While RegEnumValue(hKey, NbCl, sName, Ret, 0, ByVal 0&, ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS If RetData > 0 Then ' le nom des la cles ou programmes sont renvoye ds Left$(sName, ret) ' la commande ou le chemin du programmw sont renvoyee ds Left$(sData, RetData - 1) NbCl = NbCl + 1 'on choisi l'action Select Case Action Case 1 ' initier la liste de depart IniList(NbrLst).Add Left$(sName, Ret) Case 2 'on compte juste le nbr de cle Case 3 'ici on determine la cle qui a ete ajoutee VeriFic = 0 'MsgBox IniList(NbrLst).Count & IniList(NbrLst).Item(NbCl) For ii = 1 To IniList(NbrLst).Count If IniList(NbrLst).Item(ii) <> Left$(sName, Ret) Then VeriFic = VeriFic + 1 Next ii ' MsgBox VeriFic If VeriFic >= IniList(NbrLst).Count Then 'si il n'est pas dans la list c le bon Chm = Left$(sData, RetData - 1) 'on renvoi la valeur GetKeyNumber = Left$(sName, Ret) 'on renvoi le nom du prog GoTo Fin End If End Select 'on vide les variables ... sName = Space(BUFFER_SIZE) sData = Space(BUFFER_SIZE) Ret = BUFFER_SIZE RetData = BUFFER_SIZE End If DoEvents Wend RegCloseKey hKey 'on ferme la cle Else End If GetKeyNumber = NbCl 'on renvoi le nombre de cle Fin: DoEvents End Function Sub Main() Dim x As Long Sa(1) = "Software\Microsoft\Windows\CurrentVersion\Run" Sa(2) = "Software\Microsoft\Windows\CurrentVersion\RunOnce" Sa(3) = "Software\Microsoft\Windows\CurrentVersion\Run" Sa(4) = "Software\Microsoft\Windows\CurrentVersion\RunOnce" Sa(5) = "Software\Microsoft\Windows\CurrentVersion\RunOnceEx" Sb(1) = HKCU Sb(2) = HKCU Sb(3) = HKLM Sb(4) = HKLM Sb(5) = HKLM Path = GetPath SearchStr = "*.*" DoEvents x = InitCommonControls 'set IniList = New Collection Set IniList(1) = New Collection Set IniList(2) = New Collection Set IniList(3) = New Collection Set IniList(4) = New Collection Set IniList(5) = New Collection Set IniList(6) = New Collection DoEvents RegWrite HKCU, "Software\Abes", "StandBy", "On" 'initialisation 'on compte combien il y a de valeurs dans la cle et on les notes 'dans la collection portant le meme numero 'Ex: GetKeyNumber(hkcu, "Software\Microsoft\Windows\CurrentVersion\Run", liste1, action1) VeriF(1) = GetKeyNumber(Sb(1), Sa(1), 1, 1) DoEvents VeriF(2) = GetKeyNumber(Sb(2), Sa(2), 2, 1) DoEvents VeriF(3) = GetKeyNumber(Sb(3), Sa(3), 3, 1) DoEvents VeriF(4) = GetKeyNumber(Sb(4), Sa(4), 4, 1) DoEvents VeriF(5) = GetKeyNumber(Sb(5), Sa(5), 5, 1) DoEvents VeriF(6) = GetNumberFile(1) DoEvents Timing ' lance la boucle de verification... End Sub Public Sub MessageBox(value, programs, list As Integer) Dim reponse As Integer ' fonction d'envoi d'alerte Dim i As Integer If list <> 6 Then GoTo 1 reponse = MsgBox(" ATTENTION !" & vbCrLf & "" & vbCrLf & "Le programme : " & programs & vbCrLf & "" & vbCrLf & "s'est enregistre pour se lancer au" & vbCrLf & vbCrLf & "demarage de Windows, dans le dossier : " & vbCrLf & vbCrLf & Path & vbCrLf & "" & vbCrLf & " Voulez vous le laisser faire ? ", 4404, "RunControl") GoTo 2 1 reponse = MsgBox(" ATTENTION !" & vbCrLf & "" & vbCrLf & "Le programme : " & programs & vbCrLf & "" & vbCrLf & "a enregistre la cle suivante :" & vbCrLf & vbCrLf & value & vbCrLf & vbCrLf & "pour se lancer au demarage de Windows " & vbCrLf & "" & vbCrLf & " Voulez vous le laisser faire ? ", 4404, "RunControl") 2 Select Case reponse Case vbYes 'on met la liste a jour VeriF(list) = VeriF(list) + 1 IniList(list).Add programs DoEvents Case vbNo 'on supprime la cle ou le fichier If list <> 6 Then DeleteValue Sb(list), Sa(list), programs Else DeleteFile (Path & programs) DoEvents End If End Select End Sub Sub Timing() ' "Timer" de verification Dim Comp Dim i Dim cnt As Integer Start: 'Porte de sortie du program 'si la valeur est Off on ferme If ReadValue(HKCU, "Software\Abes", "StandBy") = "Off" Then GoTo Fin DoEvents 'verification .... For cnt = 1 To 6 ' Boucle pour verifier les cles et le dossier de demarrage ' si cnt <> de 6 on appel GetKeyNumber ' sinon on appel GetNumberFile If cnt <> 6 Then _ Comp = GetKeyNumber(Sb(cnt), Sa(cnt), cnt, 2) _ Else _ Comp = GetNumberFile(2) DoEvents 'VeriF(cnt) contient le nbr de cle(s) ou fichiers de depart 'comp contient le nbr de cle(s) ou fichiers actuel If Comp < VeriF(cnt) Then 'si il maque un fichier on reinitialise la list While IniList(cnt).Count > 0 i = IniList(cnt).Count IniList(cnt).Remove (i) Wend If cnt <> 6 Then VeriF(cnt) = GetKeyNumber(Sb(cnt), Sa(cnt), cnt, 1) Else VeriF(cnt) = GetNumberFile(1) End If DoEvents 'si comp est > VeriF(cnt) un programme a ete ajouer 'donc on appel GetKeyNumber ou GetNumberFile (action 3) pour savoir le quel If Comp > VeriF(cnt) Then 'MsgBox cnt If cnt <> 6 Then Program = GetKeyNumber(Sb(cnt), Sa(cnt), cnt, 3) Else Program = GetNumberFile(3) 'on envoi le message d'alerte Call MessageBox(Chm, Program, cnt) End If DoEvents Sleep 50 DoEvents Next cnt 'la boucle de verification est terminee, on recommence.... DoEvents DoEvents Sleep 100 GoTo Start Fin: End End Sub '-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/ Private Function StripNulls(OriginalStr As String) As String If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function Public Function GetNumberFile(Action As Integer) 'renvoi le nombre de fichier ds le repertoire Dim VeriFi 'fait a partir du code de Allapi.net Dim FileCount As Integer Dim FileName As String ' Walking filename variable... Dim i As Integer ' For-loop counter... Dim hSearch As Long ' Search Handle Dim WFD As WIN32_FIND_DATA Dim Cont As Integer If Right(Path, 1) <> "\" Then Path = Path & "\" Cont = True hSearch = FindFirstFile(Path & "*", WFD) hSearch = FindFirstFile(Path & SearchStr, WFD) Cont = True If hSearch <> INVALID_HANDLE_VALUE Then DoEvents While Cont FileName = StripNulls(WFD.cFileName) If (FileName <> ".") And (FileName <> "..") Then Select Case Action Case 1 'on initialise la liste des fichiers de depart IniList(6).Add FileName FileCount = FileCount + 1 Case 2 ' on compte juste le nbr de fichiers FileCount = FileCount + 1 Case 3 'on determine quel fichier a ete ajoute Dim ii VeriFi = 0 For ii = 1 To IniList(6).Count If IniList(6).Item(ii) <> FileName Then VeriFi = VeriFi + 1 Next ii If VeriFi >= IniList(6).Count Then GetNumberFile = FileName: GoTo Fin End Select End If Cont = FindNextFile(hSearch, WFD) ' Get next file DoEvents Wend Cont = FindClose(hSearch) End If GetNumberFile = FileCount Fin: DoEvents End Function '-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/-/
22 sept. 2006 à 23:10
En fait j'utilise CreateEvent, RegNotifyChangeKeyValue et WaitForMultipleObjects.
Je recois donc un evenement lorsqu'une cle est modifiee, je n'ai donc pas besoin de verifier a interval si il y a eu modification.
Seul probleme WaitForMultipleObjects ne gere que 64 objet(cles dans ce cas) et donc il faut creer un thread par bloc de 64 cles.
J'utilise une dll en C++ pour les threads, c'est relativement stable mais ca reste delicat.
++
22 sept. 2006 à 22:48
Je ne connais pas la méthode que tu as employée, mais elle est efficace au niveau du ratio performance/nombre de clés vérifiées, vraiment.
@+
22 sept. 2006 à 18:57
Merci, @+ (et il est vrai que cette source date un peu ;)
22 sept. 2006 à 14:29
Erf wai c'est vieux ce code, j'en ai refais un depuis, base sur RegNotifyChangeKeyValue en multithread, avec sauvegarde des cles et comparaisons au demarrage et a l'arret de Windows etc...
Par defaut il a une centaine de cles, mais on peut lui en ajouter soit une par une soit depuis un liste, possibilite aussi de verouiller des cles etc...
Tu peux le voir ici: http://systemzeb.free.fr/ZebRegNotify.zip
++
22 sept. 2006 à 13:36
Pour le nombre de clé et valeurs de clé à checker, c'est bien plus que 8 ou 30 (en comptant tout les modules démarrant au démarrage de Windows, par exemple avec l'explorateur). Faut ajouter à çà les dossiers "Demarrage" et les tasks Windows.
J'ai fait le même genre de code pour mon projet, et l'utilisation CPU pour checker toutes les clés (peut être 200) bouffe pas moins de 10% de CPU...alors si on prend une intervalle assez importante (5000 ms), çà passe, mais c'est pas fameux pour un prog. d'arrière plan. Faudrait pouvoir hooker tout çà (à la manière de Regmon, mais çà nécessite d'installer un driver, et c'est plus de mon niveau).
Voilà ! @+
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.