在任务栏上弹出自定义菜单

ljl88900 · 发表于 2010-9-19 10:42:40

本帖最后由 ljl88900 于 2010-9-19 10:56 编辑

      应用程序启动后，如果你在任务栏上右键单击该程序项，就会弹出系统默认的菜单（还原、移动...关闭）。如果你有特殊需要，就必须定制自己的菜单：

一、把下面代码复制到模块中：

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const GWL_WNDPROC = (-4)
Private 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 Const WM_SYSCOMMAND = &H112
Private Const SC_CLOSE = &HF060&
Private Const WM_CLOSE = &H10
Private Const WM_DESTROY = &H2
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
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 Type POINT
x As Long
y As Long
End Type
Private Const MF_ENABLED = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_NONOTIFY = &H80&
Private Const TPM_RETURNCMD = &H100&
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal sCaption As String) 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, nIgnored As Long) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Public SelMenuCaption As String
Dim mlOldproc As Long
Public Function Popup(param() As String) As Long
Dim iMenu As Long
Dim hMenu As Long
Dim nMenus As Long
Dim p As POINT
GetCursorPos p
hMenu = CreatePopupMenu()
nMenus = 1 + UBound(param)
For iMenu = 1 To nMenus
If Trim$(CStr(param(iMenu - 1))) = "-" Then
AppendMenu hMenu, MF_SEPARATOR, iMenu, ""
Else
AppendMenu hMenu, MF_STRING + MF_ENABLED, iMenu, CStr(param(iMenu - 1))
End If
Next iMenu
iMenu = TrackPopupMenu(hMenu, TPM_RIGHTBUTTON + TPM_LEFTALIGN + TPM_NONOTIFY + TPM_RETURNCMD, p.x, p.y, 0, GetForegroundWindow(), 0)
Dim result As Long
Dim buffer As String
Const MF_BYPOSITION = &H400&
buffer = Space(255)
result = GetMenuString(hMenu, (iMenu - 1), buffer, _
Len(buffer), MF_BYPOSITION)
SelMenuCaption = LeftB(buffer, result)
DestroyMenu hMenu
Popup = iMenu
End Function
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case WM_SYSCOMMAND
If wParam = SC_CLOSE Then
SendMessage hwnd, WM_CLOSE, ByVal 0&, ByVal 0&
End If
Case WM_DESTROY
SetWindowLong hwnd, GWL_WNDPROC, mlOldproc
End Select
If Msg = 787 And wParam = 0 Then
'以下是自定义菜单，请根据实际修改
Dim lMenuChosen As Long, s(1) As String
s(0) = "关于..."
s(1) = "关闭"
lMenuChosen = Popup(s)
Select Case lMenuChosen
Case 1
MsgBox "版权所有，侵权必究！", vbInformation, "关于"
Case 2
SendMessage hwnd, &H10, 0, 0 '关闭窗口
End Select
Exit Function
End If
WndProc = CallWindowProc(mlOldproc, hwnd, Msg, wParam, lParam)
End Function
Public Sub subclass(hwnd As Long)
Dim lStyle As Long
lStyle = GetWindowLong(hwnd, GWL_STYLE)
lStyle = lStyle Or WS_MINIMIZEBOX Or WS_SYSMENU
SetWindowLong hwnd, GWL_STYLE, lStyle
mlOldproc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub