'Make a new project. Add a module. To the form add a command button.
'Code:
'Add this code to the module:
Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
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
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
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
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
Public Sub CreateAssociation()
Dim sPath As String
'File Associations begin with a listing
'of the default extension under HKEY_CLASSES_ROOT.
'So the first step is to create that
'root extension item
CreateNewKey ".xxx", HKEY_CLASSES_ROOT
'To the extension just added, add a
'subitem where the registry will look for
'commands relating to the .xxx extension
'("MyApp.Document"). Its type is String (REG_SZ)
SetKeyValue ".xxx", "", "MyApp.Document", REG_SZ
'Create the 'MyApp.Document' item under
'HKEY_CLASSES_ROOT. This is where you'll put
'the command line to execute or other shell
'statements necessary.
CreateNewKey "MyApp.Document\shell\open\command", HKEY_CLASSES_ROOT
'Set its default item to "MyApp Document".
'This is what is displayed in Explorer against
'for files with a xxx extension. Its type is
'String (REG_SZ)
SetKeyValue "MyApp.Document", "", "MyApp Document", REG_SZ
'Finally, add the path to myapp.exe
'Remember to add %1 as the final command
'parameter to assure the app opens the passed
'command line item.
'(results in '"c:\LongPathname\Myapp.exe %1")
'Again, its type is string.
sPath = "c:\LongPathname\Myapp.exe %1"
SetKeyValue "MyApp.Document\shell\open\command", "", sPath, REG_SZ
'All done
MsgBox "The file association has been made!"
End Sub
Public Function SetValueEx(ByVal hKey As Long, _
sValueName As String, _
lType As Long, _
vValue As Variant) As Long
Dim nValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, _
sValueName, _
0&, _
lType, _
sValue, _
Len(sValue))
Case REG_DWORD
nValue = vValue
SetValueEx = RegSetValueExLong(hKey, _
sValueName, _
0&, _
lType, _
nValue, _
4)
End Select
End Function
Public Sub CreateNewKey(sNewKeyName As String, _
lPredefinedKey As Long)
'handle to the new key
Dim hKey As Long
'result of the RegCreateKeyEx function
Dim r As Long
r = RegCreateKeyEx(lPredefinedKey, _
sNewKeyName, 0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, 0&, hKey, r)
Call RegCloseKey(hKey)
End Sub
Public Sub SetKeyValue(sKeyName As String, _
sValueName As String, _
vValueSetting As Variant, _
lValueType As Long)
'result of the SetValueEx function
Dim r As Long
'handle of opened key
Dim hKey As Long
'open the specified key
r = RegOpenKeyEx(HKEY_CLASSES_ROOT, _
sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
r = SetValueEx(hKey, _
sValueName, _
lValueType, _
vValueSetting)
Call RegCloseKey(hKey)
End Sub
'Add this code to the command button:
Private Sub Command1_Click()
CreateAssociation
End Sub
