• Home
 · 
• Registry
 · 
• Registers a filename extension, assigns an icon, and a description. When you launch the extension f

Registers a filename extension, assigns an icon, and a description. When you launch the extension f

Registers a filename extension, assigns an icon, and a description. When you launch the extension file it opens the application and places the

API Declarations


Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3090
ClientLeft = 4845
ClientTop = 3225
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'****************************************************************
' Register an extension file. Copy this code to your application.
' Set the variables in the form load section as required.
' When you launch the extension file it will open the
' application and place the extension filename on the command line.
'****************************************************************

Private Const REG_SZ As Long = &H1
Private Const REG_DWORD As Long = &H4
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_USERS As Long = &H80000003

Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_BADDB As Long = 1009
Private Const ERROR_BADKEY As Long = 1010
Private Const ERROR_CANTOPEN As Long = 1011
Private Const ERROR_CANTREAD As Long = 1012
Private Const ERROR_CANTWRITE As Long = 1013
Private Const ERROR_OUTOFMEMORY As Long = 14
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_NO_MORE_ITEMS As Long = 259

Private Const KEY_ALL_ACCESS As Long = &HF003F
Private Const REG_OPTION_NON_VOLATILE As Long = 0

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32" _
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" _
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 RegSetValueEx Lib "advapi32" _
Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpValue As Any, _
ByVal cbData As Long) As Long
Dim MyApp As String
Dim MyExtension As String
Dim MyIcon As String
Dim MyType As String
Dim MyPath As String
Dim MyDescription As String




Rate Registers a filename extension, assigns an icon, and a description. When you launch the extension f

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

Private Sub RegisterExtension()

   Dim sPath As String
   Dim PhkResult As Long
   Dim hKey As Long
   
   
   
   
   CreateNewKey MyExtension, HKEY_CLASSES_ROOT
  
   CreateNewKey MyExtension & "\OpenWithList\" & MyApp & ".exe", HKEY_CLASSES_ROOT
  
   SetKeyValue MyExtension, "", MyType, REG_SZ, HKEY_CLASSES_ROOT
   
    'Set the icon file
   CreateNewKey MyExtension & "\DefaultIcon", HKEY_CLASSES_ROOT
     
   SetKeyValue MyExtension & "\DefaultIcon", "", MyIcon, REG_SZ, HKEY_CLASSES_ROOT
   
   CreateNewKey MyApp & ".Settings", HKEY_CLASSES_ROOT
   
   SetKeyValue MyApp & ".Settings", "", MyDescription, REG_SZ, HKEY_CLASSES_ROOT
  
   CreateNewKey MyApp & ".Settings\shell\open\command", HKEY_CLASSES_ROOT
  
   sPath = MyPath & "%1"
   
   SetKeyValue MyApp & ".Settings\shell\open\command", "", sPath, REG_SZ, HKEY_CLASSES_ROOT
     
   
End Sub


Private 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 = RegSetValueEx(hKey, sValueName, 0&, lType, ByVal sValue, Len(sValue))
         
      Case REG_DWORD
         nValue = vValue
         SetValueEx = RegSetValueEx(hKey, sValueName, 0&, lType, ByVal nValue, 4)
   
   End Select
   
End Function


Private Sub CreateNewKey(sNewKeyName As String, lpredefinedkey As Long)

  'handle to the new key
   Dim hKey As Long
   Dim result As Long
   
   Call RegCreateKeyEx(lpredefinedkey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, result)
   
   Call RegCloseKey(hKey)

End Sub


Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long, lpredefinedkey As Long)

  'handle of opened key
   Dim hKey As Long
   
   Call RegOpenKeyEx(lpredefinedkey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
               
   Call SetValueEx(hKey, sValueName, lValueType, vValueSetting)
                  
   Call RegCloseKey(hKey)

End Sub

Private Sub Form_Load()
Dim Loaded As String
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   'Set these as required for your application
    MyApp = "Commport"   'Name of application exe file
    MyExtension = ".cps" 'extension .cps =Comm Port Setting file
    MyPath = "c:\program files\commport\commport.exe " 'Path to the application
    MyIcon = """C:\program files\commport\net04.ico""" 'Path to the icon
    MyType = "CommPort.Settings" 'Type of file
    MyDescription = "CommPort Settings File" 'Description
   
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
    
'check to see if registry settings have already been set
Loaded = GetSetting(MyApp, "Properties", "RegLoaded", "")
    
    If Loaded = "" Then
           Call RegisterExtension
           'Make a note in registry that extensions have been registered
         SaveSetting MyApp, "Properties", "RegLoaded", "TRUE"
  
        If Err Then
            MsgBox Error$, 48
            Exit Sub
        End If
    End If
End Sub