Associate an extension with the app

Option Explicit

Private Const HKEY_CLASSES_ROOT = &H80000000

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 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

Private Const REG_SZ = 1



Public Function CreateFileAssociation(AppName As String , _
ByVal AppExtension As String , AppCommand As String ) As Boolean

    'Parameters:
    'AppName = name of application
    'AppExtension: = file extension

    'AppCommand = command line for application
    'Example:
    'CreateFileAssociation "Notepad", ".txt", "notepad.exe"

  Dim bAns As Boolean
  Dim sKeyName As String
  Dim sExtName As String
 AppExtension = Trim(AppExtension)
  If Left(AppExtension, 1) <> "." Then Exit Function
 sExtName = Mid (AppExtension, 2) & " File"
 
 bAns = WriteStringToRegistry(HKEY_CLASSES_ROOT, _
   AppExtension, "" , sExtName)
   
  If bAns Then bAns = WriteStringToRegistry(HKEY_CLASSES_ROOT, _
     sExtName & "\shell\open\command" , "" , AppCommand)
     
 CreateFileAssociation = bAns
End Function

Private Function WriteStringToRegistry(hKey As _
  Long , strPath As String , strValue As String , _
 strdata As String ) As Boolean


Dim bAns As Boolean

On Error Goto ErrorHandler
   Dim keyhand As Long
   Dim r As Long
  r = RegCreateKey(hKey, strPath, keyhand)
   If r = 0 Then
       r = RegSetValueEx(keyhand, strValue, 0, _
          REG_SZ, ByVal strdata, Len(strdata))
       r = RegCloseKey(keyhand)
    End If
   
  WriteStringToRegistry = (r = 0)

Exit Function

ErrorHandler:
   WriteStringToRegistry = False
    Exit Function
   
End Function