Как добавить собственный пункт в системное меню?
Для тех кто не знает: системное меню — это меню с пунктами «Закрыть», «Свернуть», «Восстановить» и т.д.
Но даже, если оно носит гордое имя «системное» — помните, что это тоже обычное смертное меню. Значит у него есть хэндл, значит в него АПИшно можно добавить в него свои пункты, что мы и сделаем.
Создайте проект, создайте в нем модуль и объявите в нем функции:
Public Declare Function AppendMenu Lib
"user32" Alias "AppendMenuA" (ByVal
hMenu As Long,
ByVal wFlags As Long,
ByVal wIDNewItem
As Long, ByVal lpNewItem
As Any) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const GWL_WNDPROC = (-4)
Const WM_SYSCOMMAND = &H112
Dim PrevProc As Long
Public Sub SetWindowProc()
PrevProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub KillWindowProc()
SetWindowLong Form1.hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_SYSCOMMAND And wParam = 1000 Then MsgBox "Ну чё, работает? =D", vbQuestion, "Работает?": Exit Function
End Function
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const GWL_WNDPROC = (-4)
Const WM_SYSCOMMAND = &H112
Dim PrevProc As Long
Public Sub SetWindowProc()
PrevProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub KillWindowProc()
SetWindowLong Form1.hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_SYSCOMMAND And wParam = 1000 Then MsgBox "Ну чё, работает? =D", vbQuestion, "Работает?": Exit Function
End Function
А теперь вернемся к нашей форме и дополним ее модуль кодом:
Private Sub Form_Load()
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(hWnd, 0&)
Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&)
Call AppendMenu(hSysMenu, MF_STRING, 1000, "О системном меню")
SetWindowProc
End Sub
Private Sub Form_Unload(Cancel As Integer)
KillWindowProc
End Sub
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(hWnd, 0&)
Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&)
Call AppendMenu(hSysMenu, MF_STRING, 1000, "О системном меню")
SetWindowProc
End Sub
Private Sub Form_Unload(Cancel As Integer)
KillWindowProc
End Sub
Ну и всё, запускайте проект и смотрите меню.
Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/