製作可以自動隱藏的彈出式選單 (轉)

製作可以自動隱藏的彈出式選單 (轉)[@more@]

關鍵在於對WM_ENTERIDLE訊息的處理
在選單狀態下移動滑鼠會產生WM_ENTERIDLE訊息
這時用TempPoint、WindowFromPoint可以取得當前滑鼠所指窗體的控制程式碼
再用GetClassName取得類名，與"#32768"（選單窗體的類名）進行比較
再等待1秒鐘，用keybd_event傳送VK_ESCAPE取消選單狀態

但是還是有一個的缺點：無法在滑鼠不移動的時候自動隱藏
這時需要Timer的幫忙

---

將下列貼上到記事本，並儲存為相應檔案

AutoHPopupMenu.vbp
====================================================================
Type=Exe
Form=Form1.frm
Reference=*G{00020430-0000-0000-C000-000000000046}#2.0#0#............SYSTEMstdole2.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
CodeViewDeInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPer=0
MaxNumberOfThreads=1

 

Form1.frm
====================================================================
VERSION 5.00
Begin VB.FoForm1
  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

'## ########################################
'== 與 =============================
Public Declare Function GetCursorPLib "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
  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