CodeItBetter Programming Another VB Programming Blog

'System & API - How to register file types
' Purpose  : To create file associations with default icons
' Parameters
' Required    Extension       (Str) ie ".exe"
' Required    FileType        (Str) ie "VB.Form"
' Required    FileTYpeName    (Str) ie. "Visual Basic Form"
' Required    Action          (Str) ie. "Open" or "Edit"
' Required    AppPath         (Str) ie. "C:\Myapp"
' Optional    Switch          (Str) ie. "/u"                  Default = ""
' Optional    SetIcon         (Bol)                           Default = False
' Optional    DefaultIcon     (Str) ie. "C:\Myapp,0"
' Optional    PromptOnError   (Bol)                           Default = False

' HOW IT WORKS
' Extension(Str)   Default = FileType(Str)
' FileType(Str)    Default = FileTypeName(Str)
' "DefaultIcon"     Default = DefaultIcon(Str)
' "shell"
' Action(Str)
' "command"   Default = AppPath(Str) & switch(Str) & " %1"

Option Explicit
 
Private Const REG_SZ As Long = 1
 
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const ERROR_SUCCESS = 0
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private PromptOnErr As Boolean
 
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) 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, _
    ByVal lpSecurityAttributes As Long, 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 ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
 
Public Function CreateFileAss(Extension As String, FileType As String, FileTypeName As String, _
    Action As String, AppPath As String, Optional Switch As String = "", _
    Optional SetIcon As Boolean = False, Optional DefaultIcon As String, _
    Optional PromptOnError As Boolean = False) As Boolean
    On Error GoTo ErrorHandler:
    PromptOnErr = PromptOnError
    '// Check that AppPath exists.
    If Dir(AppPath, vbNormal) = "" Then
        If PromptOnError Then MsgBox "The application path '" & AppPath & _
            "' cannot be found.", vbCritical + vbOKOnly, "DLL/OCX Register"
        CreateFileAss = False
        Exit Function
    End If
 
    Dim ERROR_CHARS As String
    ERROR_CHARS = "\/:*?<>|" &  chr ( 34)
    Dim i As Integer
 
    If Asc(Extension) <> 46 Then Extension = "." & Extension
    '// Check extension has "." at front

    '// Check for invalid chars within extension
    For i = 1 To Len(Extension)
        If InStr(1, ERROR_CHARS, Mid(Extension, i, 1), vbTextCompare) Then
            If PromptOnError Then MsgBox "The file extension '" & Extension & _
                "' contains an illegal char (\/:*?<>|" &  chr ( 34) & ").", _
                vbCritical + vbOKOnly, "DLL/OCX Register"
            CreateFileAss = False
            Exit Function
        End If
    Next
 
    If Switch <> "" Then Switch = " " & Trim(Switch)
    Action = FileType & "\shell\" & Action & "\command"
 
    Call CreateSubKey(HKEY_CLASSES_ROOT, Extension)        '// Create .xxx key
    Call CreateSubKey(HKEY_CLASSES_ROOT, Action)           '// Create action key

    If SetIcon Then
        Call CreateSubKey(HKEY_CLASSES_ROOT, (FileType & "\DefaultIcon"))    
        '// Create default icon key

        If DefaultIcon = "" Then
            '// This line of code sets the application's own icon as the default file icon
            Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(AppPath & ",0"))
        Else
            Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(DefaultIcon))
        End If
    End If
    Call SetKeyDefault(HKEY_CLASSES_ROOT, Extension, FileType)
    '// Set .xxx key default

    Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType, FileTypeName)
    '// Set file type default

    Call SetKeyDefault(HKEY_CLASSES_ROOT, Action, AppPath & Switch & " %1")
    '// Set Command line

    CreateFileAss = True
    Exit Function
 
ErrorHandler:
    If PromptOnError Then
        MsgBox "An error occured while attempting to create the file extension '" & _
            Extension & "'.", vbCritical + vbOKOnly, "DLL/OCX Register"
        CreateFileAss = False
    End If
End Function
 
Private Function CreateSubKey(RootKey As Long, NewKey As String) As Boolean
    '// This function creates a new sub key
    Dim hKey As Long, regReply As Long
    regReply = RegCreateKeyEx(RootKey, NewKey, 0&, "", REG_OPTION_NON_VOLATILE, _
        KEY_ALL_ACCESS, 0&, hKey, 0&)
 
    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then
            MsgBox "An error occured while attempting to to create a registery key.", _
                vbCritical + vbOKOnly, "DLL/OCX Register"
            CreateSubKey = False
        End If
    Else
        CreateSubKey = True
    End If
 
    Call RegCloseKey(hKey)
End Function
 
 
Private Function SetKeyDefault(RootKey As Long, Address As String, Value As String) As Boolean
    '// This function sets the default vaule of the key which is always a string
    Dim regReply As Long, hKey As Long
    regReply = RegOpenKeyEx(RootKey, Address, 0, KEY_ALL_ACCESS, hKey)
 
    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then
            MsgBox "An error occured while attempting to access the registery.", _
                vbCritical + vbOKOnly, "DLL/OCX Register"
            SetKeyDefault = False
            Exit Function
        End If
    End If
 
    Value = Value &  chr ( 0 ) 
 
    regReply = RegSetValueExString(hKey, "", 0&, REG_SZ, Value, Len(Value))
 
    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then
            MsgBox "An error occured while attempting to set key default value.", _
                vbCritical + vbOKOnly, "DLL/OCX Register"
            SetKeyDefault = False
        End If
    Else
        SetKeyDefault = True
    End If
 
    Call RegCloseKey(hKey)
End Function