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

制作可以自动隐藏的弹出式菜单 (转)[@more@]

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

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/10752043/viewspace-993764/，如需转载，请注明出处，否则将追究法律责任。

转载于:http://blog.itpub.net/10752043/viewspace-993764/