制作可以自动隐藏的弹出式菜单
关键在于对WM_ENTERIDLE消息的处理
在菜单状态下移动鼠标会产生WM_ENTERIDLE消息
这时用TempPoint、WindowFromPoint可以取得当前鼠标所指窗体的句柄
再用GetClassName取得类名，与"#32768"（菜单窗体的类名）进行比较
再等待1秒钟，用keybd_event发送VK_ESCAPE取消菜单状态
但是还是有一个的缺点：无法在鼠标不移动的时候自动隐藏
这时需要Timer控件的帮忙
将下列文件粘贴到记事本，并保存为相应文件
AutoHidePopupMenu.vbp
====================================================================
Type=Exe
Form=Form1.frm
Reference=*/G{00020430-0000-0000-C000-000000000046}#2.0#0#../../../../../../WINDOWS/SYSTEM/stdole2.tlb#OLE Automation
Module=Module1; Module1.bas
Startup="Form1"
ExeName32="AutoHidePopupMenu.exe"
Command32=""
Name="AutoHidePopupMenu"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="zyl910"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
Form1.frm
====================================================================
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "AutoHidePopupMenu"
ClientHeight = 3225
ClientLeft = 45
ClientTop = 330
ClientWidth = 4710
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3225
ScaleWidth = 4710
StartUpPosition = 3 '窗口缺省
Begin VB.Timer Timer1
Interval = 1000
Left = 2580
Top = 360
End
Begin VB.Label LblNow
AutoSize = -1 'True
Caption = "LblNow"
Height = 180
Left = 1410
TabIndex = 1
Top = 210
Width = 540
End
Begin VB.Label LblClick
AutoSize = -1 'True
Caption = "点击鼠标右键"
BeginProperty Font
Name = "宋体"
Size = 26.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 525
Left = 720
TabIndex = 0
Top = 1200
Width = 3150
End
Begin VB.Menu mnuPopup
Caption = "Popup"
Visible = 0 'False
Begin VB.Menu mnuItem1
Caption = "Item&1"
End
Begin VB.Menu mnuItem2
Caption = "Item&2"
End
Begin VB.Menu mnuItem3
Caption = "Item&3"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
'MsgBox ClassName(Me.hWnd)
LblNow.Caption = Now
Hook Me.hWnd
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
LblClick_MouseUp Button, Shift, X, Y
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnHook Me.hWnd
End Sub
Private Sub LblClick_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button And vbKeyRButton Then
'ShowMsg = True
PopupMenu mnuPopup
'ShowMsg = False
End If
End Sub
Private Sub Timer1_Timer()
LblNow.Caption = Now
'这样即使不移动鼠标，菜单也会自动隐藏
If ChkTime Then
ChkExit
End If
End Sub
Module1.bas
====================================================================
Attribute VB_Name = "Module1"
Option Explicit
'## API ########################################
'== 硬件与系统函数 =============================
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const VK_ESCAPE = &H1B
Public Const KEYEVENTF_KEYUP = &H2
Type POINTAPI
X As Long
Y As Long
End Type
'== 控件与消息函数 =============================
'CallWindowProc 把消息信息传递给指定的窗体过程
'GetClassName 为指定的窗口取得类名
'SetWindowLong 在窗体结构中为指定的窗体设置信息。返回值：Long，指定数据的前一个值。
'WindowFromPoint 返回包含了指定点的窗口的句柄。
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
Public Declare Function GetClassNameA Lib "user32" (ByVal hWnd As Long, lpClassName As Any, ByVal nMaxCount As Long) 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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'-- SetWindowLong ------------------------------
Public Const GWL_WNDPROC = -4
'===============================================
Public Const WM_ENTERIDLE = &H121
'===============================================
Public MeOldWndProc As Long '旧的窗体消息处理程序地址
Public ShowMsg As Boolean
Public OldIn As Boolean
Public OldTime As Long
Public ChkTime As Boolean
Public Function ClassName(ByVal hWnd As Long) As String
Dim StrData(0 To &H100) As Byte
Dim Rc As Long
Rc = GetClassNameA(hWnd, StrData(0), &H100)
If Rc > 0 Then
ClassName = StrConv(LeftB(StrData, Rc), vbUnicode)
Else
ClassName = vbNullString
End If
End Function
Public Sub Hook(ByVal hWnd As Long)
MeOldWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHook(ByVal hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, MeOldWndProc)
End Sub
'消息处理
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_ENTERIDLE
'Debug.Print "WM_ENTERIDLE"
ChkExit
Case Else
'If ShowMsg Then Debug.Print uMsg
'下级传递消息
WindowProc = CallWindowProc(MeOldWndProc, hWnd, uMsg, wParam, lParam)
End Select
End Function
Public Sub ChkExit()
Dim TempPoint As POINTAPI
Dim TemphWnd As Long
Dim TempBool As Boolean
GetCursorPos TempPoint
TemphWnd = WindowFromPoint(TempPoint.X, TempPoint.Y)
If TemphWnd Then
TempBool = (ClassName(TemphWnd) = "#32768")
Else
TempBool = False
End If
'Debug.Print TempBool
If TempBool <> OldIn Then
If TempBool Then
OldTime = 0
ChkTime = False
Else
OldTime = GetTickCount
ChkTime = True
End If
OldIn = TempBool
End If
If ChkTime Then
If GetTickCount - OldTime > 1000 Then '大于1秒就退出
'Debug.Print "Exit"
keybd_event VK_ESCAPE, 0, 0, 0
keybd_event VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0
ChkTime = False
End If
End If
End Sub