CodeItBetter Programming Another VB Programming Blog

'System & API - How to Associate a file extension with an executable
'Create a new project with a form and place a checkbox (chkAssoc), 
'a textbox (Text1), command dialog control (ComDia) and create a menu 
'File            (mnuFile)
'|-> Open        (mnuOpen)
'|-> Save        (mnuSave)
'|-> Save As     (mnuSaveAs)
'
'and place the following code in form code window:

Option Explicit
 
Dim fileOpen As String
Dim OrigAssoc As Boolean    
'keep chkAssoc_Click code from executing until user interfaces with it
Dim exe_File_Path As String
 
Private Sub chkAssoc_Click()
    If chkAssoc.Value = vbChecked And OrigAssoc Then
        Call AssociateFileExtension("test", exe_File_Path, "TestFile")
    ElseIf OrigAssoc Then
        Call UnAssociateFileExtension("test", "TestFile")
    End If
End Sub
 
Private Sub Form_Load()
    Dim fnum As Integer, s As String, Ret
    Text1.Text = "Do not click checkbox below when running in IDE." & vbCrLf & _
        "Save it as an exe and run the exe." & vbCrLf & "After the checkbox is checked," _
        & vbCrLf & "look in the application folder and" & vbCrLf & _
        "double click the Test Document.test"
    'see if .test file opened by double clicking
    If Command$ <> "" Then
        fnum = FreeFile
        Open Command$ For Input As fnum
        Text1.Text = Input$(LOF(fnum), #fnum)
        Close fnum
    End If
    'find out if program associated with .test files
    lpSubKey = "TestFile\shell\open\command"
    RC = RegOpenKey(HKEY_CLASSES_ROOT, lpSubKey, phkResult)
    lpData = Space(255)
    lpcbData = Len(lpData)
    RC = RegQueryValueEx(phkResult, "", 0&, REG_SZ, lpData, lpcbData)
    s = Left(lpData, lpcbData - 1)
    RC = RegCloseKey(phkResult)
    'define full path to .exe file
    exe_File_Path = App.Path
    If Right$(exe_File_Path, 1) <> "\" Then exe_File_Path = exe_File_Path & "\"
    exe_File_Path = exe_File_Path & App.EXEName
    If LCase$(Right$(exe_File_Path, 4)) <> ".exe" Then exe_File_Path = exe_File_Path & ".exe"
    'see if associated
    Ret = InStr(1, s, exe_File_Path)
    'if associated, put check in chkAssoc
    If Ret <> 0 Then
        chkAssoc.Value = vbChecked
    End If
    'keep chkAssoc_Click code from executing until user interfaces with it
    OrigAssoc = True
 
End Sub
 
Private Sub mnuOpen_Click()
    Dim fnum As Integer
    On Error GoTo ex
    ComDia.CancelError = True
    ComDia.FileName = ""
    ComDia.InitDir = App.Path
    ComDia.Flags = cdlOFNFileMustExist
    ComDia.Filter = "Test Files (*.test)|*.test"
    ComDia.Flags = &H4    'cdlOFNHideReadOnly &H4 Hides the Read Only
    ComDia.ShowOpen
    fileOpen = ComDia.FileName
    fnum = FreeFile
    Open fileOpen For Input As fnum
    Text1.Text = Input$(LOF(fnum), #fnum)
    Close fnum
    Exit Sub
 
ex:
    If Err.Number = 32755 Then Exit Sub    'user pressed cancel
    MsgBox "Error # " & Err.Number & " - " & Err.Description
End Sub
 
Private Sub mnuSave_Click()
    Dim fnum As Integer
    If fileOpen = "" Then
        mnuSaveAs_Click
    Else
        fnum = FreeFile
        Open fileOpen For Output As fnum
        ' Write the file's contents (without an
        ' extra trailing vbCrLf).
        Print #fnum, Text1.Text;
        Close fnum
    End If
End Sub
 
Private Sub mnuSaveAs_Click()
    Dim fnum As Integer
    On Error GoTo ex
    ComDia.CancelError = True
    ComDia.FileName = ""
    ComDia.InitDir = App.Path
    ComDia.Flags = cdlOFNFileMustExist
    ComDia.Filter = "Test Files (*.test)|*.test"
    ComDia.Flags = &H2    'cdlOFNOverwritePrompt &H2 Prompts for Overwrite
    ComDia.ShowSave
    fileOpen = ComDia.FileName
    fnum = FreeFile
    Open fileOpen For Output As fnum
    ' Write the file's contents (without an
    ' extra trailing vbCrLf).
    Print #fnum, Text1.Text;
    Close fnum
    Exit Sub
ex:
    If Err.Number = 32755 Then Exit Sub    'user pressed cancel
    MsgBox "Error # " & Err.Number & " - " & Err.Description
End Sub
 
'And Create a new module and place the following code:

Option Explicit
'Microsoft's answers to associating files are:
'1. HOWTO: Associate a File Extension with Your Application
'http://support.microsoft.com/default.aspx?scid=KB;en-us;q185453
'
'2. HOWTO: Associate a Custom Icon with a File Extension
'http://support.microsoft.com/default.aspx?scid=kb;en-us;247529
'========Read registry key values
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
    lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
'Note that if you declare the lpData parameter as String,
'you must pass it By Value. (In RegQueryValueEx)
Public phkResult As Long
Public lpSubKey As String
Public lpData As String
Public lpcbData As Long
Public RC As Long
'Root Key Constants
Public Const HKEY_CLASSES_ROOT = &H80000000
'Reg DataType Constants
Public Const REG_SZ = 1    ' Unicode null terminated string
'Create and delete key in registry
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, _
    ByVal lpData As String, ByVal cbData As Long) As Long
' Return codes from Registration functions.
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1&
Const ERROR_BADKEY = 2&
Const ERROR_CANTOPEN = 3&
Const ERROR_CANTREAD = 4&
Const ERROR_CANTWRITE = 5&
Const ERROR_OUTOFMEMORY = 6&
Const ERROR_INVALID_PARAMETER = 7&
Const ERROR_ACCESS_DENIED = 8&
Private Const MAX_PATH = 260&
'==included in Read registry key values
'Private Const HKEY_CLASSES_ROOT = &H80000000
'Private Const REG_SZ = 1
'This sub puts new default icon on associated files or off if unassociated
Private Declare Sub SHChangeNotify Lib "shell32.dll" (ByVal wEventId As Long, ByVal uFlags As Long, dwItem1 As Any, dwItem2 As Any)
Private Const SHCNE_ASSOCCHANGED = &H8000000
Private Const SHCNF_IDLIST = &H0&
Private Const SHCNF_FLUSHNOWAIT As Long = &H2000
 
'Extension is three letters without the "."
'PathToExecute is full path to exe file
'Application Name is any name you want as description of Extension
Public Sub AssociateFileExtension(Extension As String, PathToExecute As String, _
    ApplicationName As String)
    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.

    Ret& = InStr(1, Extension, ".")
    If Ret& <> 0 Then
        MsgBox "Extension has . in it. Remove and try again."
        Exit Sub
    End If
 
    'This creates a Root entry called 'ApplicationName'.
    sKeyName = ApplicationName
    sKeyValue = ApplicationName
    Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
 
    'This creates a Root entry for the extension to be associated with 'ApplicationName'.
    sKeyName = "." & Extension
    sKeyValue = ApplicationName
    Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    Ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
 
    'This sets the command line for 'ApplicationName'.
    sKeyName = ApplicationName
    sKeyValue = PathToExecute & " %1"
    Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    Ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
 
    'This sets the default icon
    sKeyName = ApplicationName
    sKeyValue = App.Path & "\" & App.EXEName & ".exe,0"
    Ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    Ret& = RegSetValue&(lphKey&, "DefaultIcon", REG_SZ, sKeyValue, MAX_PATH)
 
    'Force Icon Refresh
    SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0
End Sub
 
Public Sub UnAssociateFileExtension(Extension As String, ApplicationName As String)
    Dim sKeyName As String   'Finds Key Name in registry.
    Dim sKeyValue As String  'Finds Key Value in registry.
    Dim Ret&           'Holds error status, if any, from API calls.

    Ret& = InStr(1, Extension, ".")
    If Ret& <> 0 Then
        MsgBox "Extension has . in it. Remove and try again."
        Exit Sub
    End If
 
    'This deletes the default icon
    sKeyName = ApplicationName
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName & "\DefaultIcon")
 
    'This deletes the command line for "ApplicationName".
    sKeyName = ApplicationName
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName & "\shell\open\command")
 
    'This deletes a Root entry called "ApplicationName".
    sKeyName = ApplicationName
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName & "\shell\open")
 
    'This deletes a Root entry called "ApplicationName".
    sKeyName = ApplicationName
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName & "\shell")
 
    'This deletes a Root entry called "ApplicationName".
    sKeyName = ApplicationName
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName)
 
    'This deletes the Root entry for the extension to be associated with "ApplicationName".
    sKeyName = "." & Extension
    Ret& = RegDeleteKey(HKEY_CLASSES_ROOT, sKeyName)
 
    'Force Icon Refresh
    SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST & SHCNF_FLUSHNOWAIT, 0, 0
End Sub