Visual Basic

<br />
'CALLING FUNCTION<br />
Call FileAssociation.CreateAssociation("MyFile", "tru", "Myfile File", "Mydll.dll") ' associate tru with icon<br />
<br />
'MODULE<br />
' Usage:<br />
' CreateAssociation Program name, Extension, Description, Iconfile<br />
' EX:<br />
' CreateAssociation "Cryo", "cdf", "Cryo Datafile", "Cryo.dll, 0"<br />
'<br />
'<br />
<br />
Option Explicit<br />
<br />
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long<br />
Public 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<br />
Public 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<br />
Public 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<br />
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long<br />
<br />
Public Const REG_SZ As Long = 1<br />
Public Const REG_DWORD As Long = 4<br />
Public Const HKEY_CLASSES_ROOT = &H80000000<br />
Public Const HKEY_CURRENT_USER = &H80000001<br />
Public Const HKEY_LOCAL_MACHINE = &H80000002<br />
Public Const HKEY_USERS = &H80000003<br />
Public Const ERROR_NONE = 0<br />
Public Const ERROR_BADDB = 1<br />
Public Const ERROR_BADKEY = 2<br />
Public Const ERROR_CANTOPEN = 3<br />
Public Const ERROR_CANTREAD = 4<br />
Public Const ERROR_CANTWRITE = 5<br />
Public Const ERROR_OUTOFMEMORY = 6<br />
Public Const ERROR_INVALID_PARAMETER = 7<br />
Public Const ERROR_ACCESS_DENIED = 8<br />
Public Const ERROR_INVALID_PARAMETERS = 87<br />
Public Const ERROR_NO_MORE_ITEMS = 259<br />
Public Const KEY_ALL_ACCESS = &H3F<br />
Public Const REG_OPTION_NON_VOLATILE = 0<br />
<br />
Public Sub CreateAssociation(PROG As String, EXT As String, BESKRIV As String, IconLib As String)<br />
        Dim sPath As String<br />
        sPath = App.path & "\" & App.EXEName & " %1"<br />
        <br />
        CreateNewKey "." & EXT, HKEY_CLASSES_ROOT<br />
        SetKeyValue "." & EXT, "", PROG, REG_SZ<br />
        <br />
        CreateNewKey PROG & "\shell\open\command", HKEY_CLASSES_ROOT<br />
        CreateNewKey PROG & "\DefaultIcon", HKEY_CLASSES_ROOT<br />
        <br />
        SetKeyValue PROG, "", BESKRIV, REG_SZ<br />
        SetKeyValue PROG & "\shell\open\command", "", sPath, REG_SZ<br />
        SetKeyValue PROG & "\DefaultIcon", "", IconLib, REG_SZ<br />
End Sub<br />
Public Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)<br />
        'handle to the new key<br />
        Dim hKey As Long<br />
        'result of the RegCreateKeyEx function<br />
        Dim r As Long<br />
        r = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, r)<br />
        Call RegCloseKey(hKey)<br />
End Sub<br />
<br />
Public Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)<br />
        'result of the SetValueEx function<br />
        Dim r As Long<br />
        'handle of opened key<br />
        Dim hKey As Long<br />
        'open the specified key<br />
        r = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_ALL_ACCESS, hKey)<br />
        r = SetValueEx(hKey, sValueName, lValueType, vValueSetting)<br />
        Call RegCloseKey(hKey)<br />
End Sub<br />
<br />
<br />
Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long<br />
        Dim nValue As Long<br />
        Dim sValue As String<br />
        Select Case lType<br />
        Case REG_SZ<br />
                sValue = vValue & Chr$(0)<br />
                SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))<br />
        Case REG_DWORD<br />
                nValue = vValue<br />
                SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, nValue, 4)<br />
        End Select<br />
End Function<br />
<br />
<br />
<br />
<br />