网页资讯视频图片知道文库贴吧地图采购
进入贴吧全吧搜索
vb吧 关注：155,997贴子：1,166,264

实用 呼出系统菜单

如果你不想只能在标题栏上单击鼠标右键才能弹出系统菜单。
你可以使用一下方法。这个方法在自绘标题栏方面很实用。

新建模块,代码如下:

Option Explicit
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal Hwnd As Long, lprc As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal Hwnd As Long, ByVal bRevert As Long) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type POINTAPI
        X As Long
        Y As Long
End Type

Public Sub ShowSystemMenu(Hwnd As Long)
On Error Resume Next
    Dim r As RECT
    Dim p As POINTAPI
        GetCursorPos p
        TrackPopupMenu GetSystemMenu(Hwnd, 0&), 0, p.X, p.Y, 0, Hwnd, r
End Sub


窗口代码如下:
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then Call ShowSystemMenu(Me.Hwnd)
End Sub



上面的方法调出得系统菜单只能看不能用。用下面这个方法可以更正这个问题。
不过要使用到钩子：
本例子只需要一个窗口和一个模块。无需任何控件:
模块:

Option Explicit
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 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
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public ProcOld As Long
Public Const TPM_LEFTALIGN = &H0&
Public Const WM_SYSCOMMAND = &H112
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const IDM_ABOUT As Long = 1010
Public Const WM_COMMAND = &H111
Public lRet As Long


Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type
Private Type POINTAPI
 X As Long
 Y As Long
End Type

Public Sub ShowSystemMenu(hwnd As Long)
On Error Resume Next
 Dim r As RECT
 Dim p As POINTAPI
 GetCursorPos p
 TrackPopupMenu GetSystemMenu(hwnd, 0&), 0, p.X, p.Y, 0, hwnd, r
End Sub


Public Function WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Select Case iMsg
 Case WM_SYSCOMMAND
 If wParam = IDM_ABOUT Then
 MsgBox "VB Web Append to System Menu Example", vbInformation, "About"

Exit Function
 End If
 Case WM_COMMAND
 CallWindowProc ProcOld, hwnd, WM_SYSCOMMAND, wParam, lParam
 WindowProc = 0
 Exit Function
 End Select
 WindowProc = CallWindowProc(ProcOld, hwnd, iMsg, wParam, lParam)
End Function



窗口:

Option Explicit

Private Sub Form_Load()
ProcOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then Call ShowSystemMenu(Me.hwnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
SetWindowLong hwnd, GWL_WNDPROC, ProcOld
End Sub


2026-09-09 22:14:04
广告
不感兴趣
开通SVIP免广告
很好，3Q，收藏了


发现个问题，如果窗口上有按钮，就不能用了。

Private Sub Command1_Click()
Print "aa"
End Sub

就显示不出来了


顶一下，可惜没注释。
哎，VB程序员的通病...


如果是没边框的窗口,想要在任务栏也用菜单怎么弄?谁会?


'系统菜单不用子类化就行了阿，菜单+菜单功能
Private Type POINTAPI
 x As Long
 y As Long
End Type
Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type
Private Const HTCAPTION = 2
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_SYSCOMMAND = &H112
Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
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 Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
 If Button = 2 Then
 Dim vPoint As POINTAPI
 Dim vRect As RECT
 Call GetCursorPos(vPoint)
 Call SendMessage(Me.hwnd, WM_SYSCOMMAND, TrackPopupMenu(GetSystemMenu(Me.hwnd, 0), _
 TPM_RETURNCMD Or TPM_LEFTBUTTON, vPoint.x, vPoint.y, 0, Me.hwnd, vRect), 0)
 End If
End Sub


还是解决不了8楼的问题


2026-09-09 22:08:04
广告
不感兴趣
开通SVIP免广告
快试试吧，
可以对自己使用挽尊卡咯~
◆
◆
........


快试试吧，
可以对自己使用挽尊卡咯~
◆
◆
9楼 Ultraman_King 的方法是最好的。代码简单


To 8F 想要没标题栏又要有系统菜单。看看这个：



Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Const GWL_STYLE = (-16)

Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000

Private Sub Form_Initialize()
 Dim lStyle As Long
 lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
 lStyle = lStyle And Not WS_CAPTION
 lStyle = lStyle And Not WS_THICKFRAME
 lStyle = lStyle Or WS_SYSMENU
 SetWindowLong Me.hwnd, GWL_STYLE, lStyle
 Me.Refresh
End Sub


无标题栏 + 系统菜单:

使用了8楼老师的代码，我那段代码太繁杂：




Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Type POINTAPI
 X As Long
 Y As Long
End Type
Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type
Private Const HTCAPTION = 2
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_SYSCOMMAND = &H112
Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
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 Const GWL_STYLE = (-16)

Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000

Private Sub Form_Initialize()
 Dim lStyle As Long
 lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
 lStyle = lStyle And Not WS_CAPTION
 lStyle = lStyle And Not WS_THICKFRAME
 lStyle = lStyle Or WS_SYSMENU
 SetWindowLong Me.hwnd, GWL_STYLE, lStyle
 Me.Refresh
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
 Dim vPoint As POINTAPI
 Dim vRect As RECT
 Call GetCursorPos(vPoint)
 Call SendMessage(Me.hwnd, WM_SYSCOMMAND, TrackPopupMenu(GetSystemMenu(Me.hwnd, 0), _
 TPM_RETURNCMD Or TPM_LEFTBUTTON, vPoint.X, vPoint.Y, 0, Me.hwnd, vRect), 0)
 End If

End Sub


扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！
分享到: