Подготовте проект, добавив в него форму.
Добавте в форму:
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Call ReleaseCapture
Call SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
 | Регистрация нового типа файлов в Windows |
Если в вашем приложении вам нужно зарегистрировать новый тип файла или создать ассоциацию этого типа файла с вашим приложением (по-умолчанию запускать вашу программу с этим типом файлов), то используйте приведенный ниже код.
Подговте проект с формой.
На форму поместите:
- Кнопку с именем Command1
Добавте в форму:
Private Type mnuCommands
Captions As New Collection
Commands As New Collection
End Type
Private Type filetype
Commands As mnuCommands
Extension As String
ProperName As String
FullName As String
ContentType As String
IconPath As String
IconIndex As Integer
End Type
Private Const REG_SZ = 1
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Declare Function RegCloseKey Lib _
"advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib _
"advapi32" Alias "RegCreateKeyA" (ByVal _
hKey As Long, ByVal lpszSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib _
"advapi32" Alias "RegSetValueExA" (ByVal _
hKey As Long, ByVal lpszValueName As String, _
ByVal dwReserved As Long, ByVal fdwType As _
Long, lpbData As Any, ByVal cbData As Long) As Long
Private Sub CreateExtension(newfiletype As filetype)
Dim IconString As String
Dim Result As Long, Result2 As Long, ResultX As Long
Dim ReturnValue As Long, HKeyX As Long
Dim cmdloop As Integer
IconString = newfiletype.IconPath & "," & _
newfiletype.IconIndex
If Left$(newfiletype.Extension, 1) <> "." Then _
newfiletype.Extension = "." & newfiletype.Extension
RegCreateKey HKEY_CLASSES_ROOT, _
newfiletype.Extension, Result
ReturnValue = RegSetValueEx(Result, "", 0, REG_SZ, _
ByVal newfiletype.ProperName, _
LenB(StrConv(newfiletype.ProperName, vbFromUnicode)))
If newfiletype.ContentType <> "" Then
ReturnValue = RegSetValueEx(Result, _
"Content Type", 0, REG_SZ, ByVal _
CStr(newfiletype.ContentType), _
LenB(StrConv(newfiletype.ContentType, vbFromUnicode)))
End If
RegCreateKey HKEY_CLASSES_ROOT, _
newfiletype.ProperName, Result
If Not IconString = ",0" Then
RegCreateKey Result, "DefaultIcon", _
Result2 'Создать ID для "ProperNameDefaultIcon"
ReturnValue = RegSetValueEx(Result2, _
"", 0, REG_SZ, ByVal IconString, _
LenB(StrConv(IconString, vbFromUnicode)))
'Установить значение по-умолчанию для ID
End If
ReturnValue = RegSetValueEx(Result, _
"", 0, REG_SZ, ByVal newfiletype.FullName, _
LenB(StrConv(newfiletype.FullName, vbFromUnicode)))
RegCreateKey Result, ByVal "Shell", ResultX
'Создать необходимые ID для каждой команды
For cmdloop = 1 To newfiletype.Commands.Captions.Count
RegCreateKey ResultX, ByVal _
newfiletype.Commands.Captions(cmdloop), Result
RegCreateKey Result, ByVal "Command", Result2
Dim CurrentCommand$
CurrentCommand = newfiletype.Commands.Commands(cmdloop)
ReturnValue = RegSetValueEx(Result2, _
"", 0, REG_SZ, ByVal CurrentCommand$, _
LenB(StrConv(CurrentCommand$, vbFromUnicode)))
RegCloseKey Result
RegCloseKey Result2
Next
RegCloseKey Result2
End Sub
Private Sub Command1_Click()
Dim myfiletype As filetype
myfiletype.ProperName = "TXT FILE"
myfiletype.FullName = "Текстовый файл"
myfiletype.ContentType = "TXT"
myfiletype.Extension = ".txt"
myfiletype.Commands.Captions.Add "Open"
myfiletype.Commands.Commands.Add "c:\windows\notepad.exe ""%1"""
myfiletype.Commands.Captions.Add "Print"
myfiletype.Commands.Commands.Add "c:\windows\notepad.exe ""%1"" /P"
CreateExtension myfiletype
End Sub
