GFRegisterFileType/Mfrm.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4155
ClientLeft = 60
ClientTop = 345
ClientWidth = 4635
LinkTopic = "Form1"
ScaleHeight = 4155
ScaleWidth = 4635
StartUpPosition = 3 'Windows‑Standard
Begin VB.TextBox Text6
Height = 285
Left = 2160
TabIndex = 12
Text = "0"
Top = 2820
Width = 2415
End
Begin VB.TextBox Text5
Height = 285
Left = 2160
TabIndex = 11
Text = "C:\Windows\Notepad.exe"
Top = 2400
Width = 2415
End
Begin VB.CommandButton Command3
Caption = "IsRegistered"
Height = 375
Left = 660
TabIndex = 2
Top = 3720
Width = 1935
End
Begin VB.TextBox Text4
Height = 285
Left = 2160
TabIndex = 6
Text = "C:\Windows\Notepad.exe"
Top = 1560
Width = 2415
End
Begin VB.TextBox Text3
Height = 285
Left = 2160
TabIndex = 5
Text = "GFRegisterFileType Test FileType"
Top = 1080
Width = 2415
End
Begin VB.TextBox Text2
Height = 285
Left = 2160
TabIndex = 4
Text = "BlahFile"
Top = 600
Width = 2415
End
Begin VB.TextBox Text1
Height = 285
Left = 2160
TabIndex = 3
Text = "blah"
Top = 120
Width = 2415
End
Begin VB.CommandButton Command2
Caption = "Unregister File Type"
Height = 375
Left = 2640
TabIndex = 1
Top = 3720
Width = 1935
End
Begin VB.CommandButton Command1
Caption = "Register File Type"
Height = 375
Left = 2640
TabIndex = 0
Top = 3300
Width = 1935
End
Begin VB.Label Label6
Caption = "IconIndex"
Height = 195
Left = 60
TabIndex = 14
Top = 2880
Width = 1455
End
Begin VB.Label Label5
Caption = "IconFile"
Height = 195
Left = 60
TabIndex = 13
Top = 2460
Width = 1455
End
Begin VB.Label Label4
Caption = "run command (e.g. 'C:\MyApp\App.exe ""%1""')"
Height = 435
Left = 60
TabIndex = 10
Top = 1560
Width = 1995
End
Begin VB.Label Label3
Caption = "user description (e.g. 'executable')"
Height = 435
Left = 60
TabIndex = 9
Top = 1080
Width = 1455
End
Begin VB.Label Label2
Caption = "internal description (e.g. ExeFile)"
Height = 435
Left = 60
TabIndex = 8
Top = 600
Width = 1455
End
Begin VB.Label Label1
Caption = "file type (e.g. 'exe')"
Height = 435
Left = 60
TabIndex = 7
Top = 120
Width = 1455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2004 by Louis. Use to let the user start any program by double clicking a related registered file.
'
'Downloaded from www.louis‑coder.com.
'Code to register any file type.
'Uses Rmod, module containing Windows‑Registry access functions.
Private Sub Command1_Click()
'on error resume next
Debug.Print GFRegisterFileType_RegisterFileType( _
Text1.Text, Text2.Text, Text3.Text, Text4.Text, Text5.Text, Val(Text6.Text))
End Sub
Private Sub Command2_Click()
'on error resume next
Debug.Print GFRegisterFileType_UnregisterFileType(Text1.Text)
End Sub
Private Sub Command3_Click()
'on error resume next
Dim Tempstr$
Debug.Print GFRegisterFileType_IsRegistered(Text1.Text, Tempstr$)
Debug.Print Tempstr$
End Sub
'***GFREGISTERFILETYPE***
Private Function GFRegisterFileType_RegisterFileType(ByVal FileType As String, ByVal FileTypeName As String, ByVal FileTypeDescription As String, ByVal FileTypeCommand As String, ByVal IconFile As String, ByVal IconIndex As Integer) As Boolean
'on error resume next
'verify
If Len(FileType) = 0 Then GoTo Error:
If Len(FileTypeName) = 0 Then GoTo Error:
If Right$(FileTypeName, 1) = "\" Then FileTypeName = Left$(FileTypeName, Len(FileTypeName) ‑ 1) 'will serve as reg sub key
If Len(FileTypeDescription) = 0 Then GoTo Error:
If Len(FileTypeCommand) = 0 Then GoTo Error:
'IconFile and Index may be undefined
'reset
Rmod.RegCreateSubKeyErrorFlag = False 'reset
Rmod.RegSetKeyValueErrorFlag = False 'reset
'begin
Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "." + LCase$(FileType))
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, "." + LCase$(FileType), "", CVar(FileTypeName), REG_SZ) 'set default value
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileTypeName)
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, FileTypeName, "", CVar(FileTypeDescription), REG_SZ)
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileTypeName + "\shell\open\command")
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, FileTypeName + "\shell\open\command", "", CVar(FileTypeCommand), REG_SZ)
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileTypeName + "\DefaultIcon")
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, FileTypeName + "\DefaultIcon", "", CVar(IconFile + "," + LTrim$(Str$(IconIndex))), REG_SZ)
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
GFRegisterFileType_RegisterFileType = True 'ok
Exit Function
Error:
GFRegisterFileType_RegisterFileType = False 'error
Exit Function
End Function
Private Function GFRegisterFileType_IsRegistered(ByVal FileType As String, ByRef FileTypeDescriptionExisting As String) As Boolean
'on error resume next 'returns True and sets FileTypeDescriptionExisting (e.g. 'Notepad document') if passed file type is registered, False if not
Dim Tempstr$
'begin
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "." + FileType, "")
If Rmod.RegGetKeyValueErrorFlag = False Then
GFRegisterFileType_IsRegistered = True
FileTypeDescriptionExisting = Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, Tempstr$, "")
Else
GFRegisterFileType_IsRegistered = False
FileTypeDescriptionExisting = "" 'reset
End If
End Function
Private Function GFRegisterFileType_UnregisterFileType(ByVal FileType As String) As Boolean
'on error resume next 'returns True if file type has been unregistered, False if not
Dim Tempstr$
'
'NOTE: the file type to unregister should have been created using
'GFRegisterFileType_RegisterFileType() and should have stayed untouched
'(special sub keys will be deleted only).
'
'reset
Rmod.RegGetKeyValueErrorFlag = False 'reset
Rmod.RegDeleteKeyErrorFlag = False 'reset
'begin
Tempstr$ = Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "." + FileType, "") 'get FileTypeName
If Tempstr$ = "" Then GoTo Error: 'important (or all HKEY_CLASSES_ROOT sub keys will be erased)
If Rmod.RegGetKeyValueErrorFlag = True Then GoTo Error:
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, Tempstr$ + "\DefaultIcon")
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, Tempstr$ + "\shell\open\command")
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, Tempstr$ + "\shell\open")
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, Tempstr$ + "\shell")
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, Tempstr$)
Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, "." + FileType)
If Rmod.RegDeleteKeyErrorFlag = True Then GoTo Error:
GFRegisterFileType_UnregisterFileType = True 'ok
Exit Function
Error:
GFRegisterFileType_UnregisterFileType = False 'error
Exit Function
End Function
'***END OF GFREGISTERFILETYPE***
[END OF FILE]