制作可以自动隐藏的弹出式菜单

关键在于对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