ضع هذا الكود في Module
[code]
Option Explicit
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 256&

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

Private Declare Function FindFirstFile Lib "kernel32" _
   Alias "FindFirstFileA" _
   (ByVal lpFileName As String, _
   lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
   (ByVal hFindFile As Long) As Long
Enum FlagConstants
  cdlOFNAllowMultiselect = &H200 'The user can select more than one file atrun time by pressing the SHIFT key and using the UP ARROW and DOWN ARROW keys to select the desired files. When this is done, the FileName property returns a string containing the names of all selected files. The names in the string are delimited by spaces.
  cdlOFNCreatePrompt = &H2000 ' Specifies that the dialog box prompts the user to create a file that doesn't currently exist. This flag automatically sets the cdlOFNPathMustExist and cdlOFNFileMustExist flags.
  cdlOFNExplorer = &H80000 ' Use the Explorer-like Open A File dialog box template. Works with Windows 95 and Windows NT 4.0.
  CdlOFNExtensionDifferent = &H400 ' Indicates that the extension of the returned filename is different from the extension specified by the DefaultExt property. This flag isn't set if the DefaultExt property is Null, if the extensions match, or if the file has no extension. This flag value can be checked upon closing the dialog box.
  cdlOFNFileMustExist = &H1000 ' Specifies that the user can enter only names of existing files in the File Name text box. If this flag is set and the user enters an invalid filename, a warning is displayed. This flag automatically sets the cdlOFNPathMustExist flag.
  cdlOFNHelpButton = &H10 ' Causes the dialog box to display the Help button.
  cdlOFNHideReadOnly = &H4 'Hides the Read Onlycheck box.
  cdlOFNLongNames = &H200000 ' Use long filenames.
  cdlOFNNoChangeDir = &H8 'Forces the dialog box to set the current directory to what it was when the dialog box was opened.
  CdlOFNNoDereferenceLinks = &H100000 ' Do not dereference shell links (also known as shortcuts). By default, choosing a shell link causes it to be dereferenced by the shell.
  cdlOFNNoLongNames = &H40000 ' No long file names.
  CdlOFNNoReadOnlyReturn = &H8000 ' Specifies that the returned file won't have the Read Only attribute set and won't be in a write-protected directory.
  cdlOFNNoValidate = &H100 ' Specifies that the common dialog box allows invalid characters in the returned filename.
  cdlOFNOverwritePrompt = &H2 'Causes the Save As dialog box to generate a message box if the selected file already exists. The user must confirm whether to overwrite the file.
  cdlOFNPathMustExist = &H800 ' Specifies that the user can enter only valid paths. If this flag is set and the user enters an invalid path, a warning message is displayed.
  cdlOFNReadOnly = &H1 'Causes the Read Only check box to be initially checked when the dialog box is created. This flag also indicates the state of the Read Only check box when the dialog box is closed.
  cdlOFNShareAware = &H4000 ' Specifies that sharing violation errors will be ignored.
End Enum

'*****************************************associate
Private Declare Function RegCreateKey& Lib "advapi32.DLL" _
Alias "RegCreateKeyA" (ByVal hKey&, ByVal lpszSubKey$, lphKey&)

Private Declare Function RegSetValue& Lib "advapi32.DLL" Alias "RegSetValueA" _
(ByVal hKey&, ByVal lpszSubKey$, ByVal fdwType&, ByVal lpszValue$, ByVal dwLength&)

' Return codes from Registration functions.
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_BADDB = 1&
Private Const ERROR_BADKEY = 2&
Private Const ERROR_CANTOPEN = 3&
Private Const ERROR_CANTREAD = 4&
Private Const ERROR_CANTWRITE = 5&
Private Const ERROR_OUTOFMEMORY = 6&
Private Const ERROR_INVALID_PARAMETER = 7&
Private Const ERROR_ACCESS_DENIED = 8&
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const REG_SZ = 1
'************************************************

Public Function Associate(ByVal apPath As String, ByVal Ext As String) As Boolean

  Dim sKeyName As String 'Holds Key Name in registry.
  Dim sKeyValue As String 'Holds Key Value in registry.
  Dim ret& 'Holds Error status If any from API calls.
  Dim lphKey& 'Holds created key handle from RegCreateKey.
  
  Dim apTitle As String
  If Not FileExists(apPath) Then Exit Function
  apTitle = ParseName(apPath)
  
  If InStr(Ext, ".") = 0 Then Ext = "." & Ext
  
  'register .ext files as belonging to app
  sKeyName = Ext
  sKeyValue = apTitle
  ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
  If ret& <> 0 Then GoTo AssocFailed
  ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
  If ret& <> 0 Then GoTo AssocFailed
  
  'set open command to path and filename
  sKeyName = apTitle
  sKeyValue = apPath & " %1"
  ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
  If ret& <> 0 Then GoTo AssocFailed
  ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
  If ret& <> 0 Then GoTo AssocFailed
  
  'register app icon with .ext files
  sKeyValue = apPath
  ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
  If ret& <> 0 Then GoTo AssocFailed
  ret& = RegSetValue&(lphKey&, "DefaultIcon", REG_SZ, sKeyValue, MAX_PATH)
  If ret& <> 0 Then GoTo AssocFailed
  
  Associate = True
  Exit Function
  
AssocFailed:
  Associate = False
End Function

Public Function ParseName(ByVal sPath As String) As String
  Dim strX As String
  Dim intX As Integer
  
  intX = InStrRev(sPath, "\")
  
  strX = Trim(Right(sPath, Len(sPath) - intX))
  If Right(strX, 1) = Chr(0) Then
    ParseName = Left(strX, Len(strX) - 1)
  Else
    ParseName = strX
  End If
End Function
Private Function FileExists(sSource As String) As Boolean
   
   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   
   hFile = FindFirstFile(sSource, WFD)
   FileExists = hFile <> INVALID_HANDLE_VALUE
   
   Call FindClose(hFile)
   
End Function
[/code]
يتم تشغيل الكود بالشكل التالي
[code]
        bGood = Associate(strFile, strExt)
        If bGood Then
          MsgBox "تمت العملية بنجاح", , "فتح بواسطة"
        Else
          MsgBox "فشل إتمام العملية", , "فتح بواسطة"
        End If
[/code]
حيث strFile هو اسم البرنامج و strExt هو الإمتداد المطلوب ربطه بالبرنامج



تحياتي .. مكتبة الأكواد