Base de registre : associer une extension

Le code suivant vous permet d'associer une extension de fichier avec votre application :

Option Explicit Private Const REG_SZ = 1 Private Const HKEY_CLASSES_ROOT = &H80000000 Private Const KEY_SET_VALUE = &H2 Private Const KEY_CREATE_SUB_KEY = &H4 Private Const SYNCHRONIZE = &H100000 Private Const READ_CONTROL = &H20000 Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) Private Const KEY_WRITE = _ ((STANDARD_RIGHTS_WRITE Or _ KEY_SET_VALUE Or _ KEY_CREATE_SUB_KEY) And _ (Not SYNCHRONIZE)) Private Const REG_OPTION_NON_VOLATILE = 0 Private Const ERROR_SUCCESS = 0& 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 RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey 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 Sub MakeAssoc(ByVal strFileExtension As String, _ Optional ByVal strAppPath As String, _ Optional ByVal strCommandLine As String = " ""%1""", _ Optional ByVal strIconPath As String, _ Optional ByVal lngIconIndex As Long, _ Optional ByVal strVerb As String, _ Optional ByVal strVerbDisplay As String, _ Optional ByVal blnKillPrecedingProgid As Boolean = False) Dim hKeyExtRoot As Long, hKeyExtSub As Long If strFileExtension = "" Then MsgBox "Une extension de fichier doit être spécifiée!" Else If RegCreateKeyEx(HKEY_CLASSES_ROOT, strFileExtension, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_WRITE, ByVal 0&, hKeyExtRoot, ByVal 0&) = ERROR_SUCCESS Then If strAppPath = "" Then 'S'il n'y a aucun chemin, utilise le chemin de cette application strAppPath = EndPath(App.Path) & App.EXEName & ".exe" End If If strVerb = "" Then 'Si aucun "Verb" n'a été définit, utilise celui par défaut: open strVerb = "Open" End If If strIconPath = "" Then 'S'il n'y a aucun chemin, utilise le chemin de cette application strIconPath = EndPath(App.Path) & App.EXEName & ".exe" End If If lngIconIndex = 0 Then 'Si aucun index d'icône n'a été définit ou que celui-ci est nul If LCase$(Right$(strIconPath, 3)) <> "ico" Then 'Si le fichier n'est pas un fichier ico, on construit une chaine contenant l'index strIconPath = strIconPath & "," & lngIconIndex End If Else 'Sinon, on construit une chaine simple contenant l'index strIconPath = strIconPath & "," & lngIconIndex End If 'S'il le faut, tue les informations précédentes stoquées dans un progid. If blnKillPrecedingProgid Then If RegSetValueEx(hKeyExtRoot, "", 0, REG_SZ, "", 0) <> ERROR_SUCCESS Then MsgBox "Impossible de définir la valeur! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If End If 'On crée une sous clé shell contenant le nouveau verb ou on ouvre celle existante If RegCreateKeyEx(hKeyExtRoot, "Shell\" & strVerb, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_WRITE, ByVal 0&, hKeyExtSub, ByVal 0&) = ERROR_SUCCESS Then 'On définit le texte affiché pour le verb If RegSetValueEx(hKeyExtSub, "", 0, REG_SZ, ByVal strVerbDisplay, Len(strVerbDisplay)) <> ERROR_SUCCESS Then MsgBox "Impossible de définir la valeur! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If RegCloseKey (hKeyExtSub) Else MsgBox "Impossible de créer la clé! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If 'On ajoute la clé command et le programme avec lequel exécuter le fichier If RegCreateKeyEx(hKeyExtRoot, "Shell\" & strVerb & "\Command", 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_WRITE, ByVal 0&, hKeyExtSub, ByVal 0&) = ERROR_SUCCESS Then If RegSetValueEx(hKeyExtSub, "", 0, REG_SZ, ByVal strAppPath & strCommandLine, Len(strAppPath & strCommandLine)) <> ERROR_SUCCESS Then MsgBox "Impossible de définir la valeur! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If RegCloseKey (hKeyExtSub) Else MsgBox "Impossible de créer la clé! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If 'On ajoute l'icône If RegCreateKeyEx(hKeyExtRoot, "DefaultIcon", 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_WRITE, ByVal 0&, hKeyExtSub, ByVal 0&) = ERROR_SUCCESS Then If RegSetValueEx(hKeyExtSub, "", 0, REG_SZ, ByVal strIconPath, Len(strIconPath)) <> ERROR_SUCCESS Then MsgBox "Impossible de définir la valeur! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If RegCloseKey (hKeyExtSub) Else MsgBox "Impossible de créer la clé! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If RegCloseKey (hKeyExtRoot) Else MsgBox "Impossible de créer la clé! Vérifiez que vous avez les droits requis pour effectuer cette opération!" End If End If End Sub Private Function EndPath(strPath As String) As String If Right(strPath, 1) <> "\" Then EndPath = strPath & "\" Else EndPath = strPath End If End Function 'Exemples d'utilisation: 'Associe l'extension .toto au programme qui apelle la fonction MakeAssoc ".toto" 'Associe l'extension .toto au programme qui apelle la fonction; Affiche "Tester Toto" en utilisant la command par défaut "ouvrir" dans le menu contextuel MakeAssoc ".toto", , , , , , "Tester Toto" 'Associe l'extension .toto au programme qui apelle la fonction; Affiche "Tester Toto" dans le menu contextuel, tout en appelant le "verb" toto MakeAssoc ".toto", , , , , "toto", "Tester Toto" 'Associe l'extention ".test" à toto.exe en utilisant la seconde icône d'une dll MakeAssoc ".test", "c:\toto.exe", , "c:\windows\system\MyIconsLib.dll", 2