VBA- MouseMove 打开和关闭另一个用户窗体
VBA- MouseMove to open and close another userform
我有一个带有多个标签控件的用户窗体，它们都属于一个 class，在鼠标悬停时，将显示另一个包含有关该标签的一些信息的用户窗体。现在我希望在鼠标离开控件后关闭该表单。现在我正在使用 application.ontime 并在 2 秒后关闭第二个表单，这使得当鼠标仍在标签上时表单闪烁。我想知道有没有更好的？到目前为止，这是我的代码。
我在 class 模块上的代码
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim m
On Error Resume Next
If Button = XlMouseButton.xlPrimaryButton And LabelBase.Edit.Caption = "Done" Then
Label1.Left = Label1.Left + X - x_offset
Label1.Top = Label1.Top + Y - y_offset
ElseIf LabelBase.Edit.Caption = "Edit" Then
With CurrentJob
.Caption = "Current Job of " & Label1.Caption
.LBcurr.list = openJobs
.LLast = LastJob
.LClsd = WorksheetFunction.CountIfs(oprecord.Range("e:e"), Label1.Caption, oprecord.Range("f:f"), Date, oprecord.Range("s:s"), "CLOSED")
.LAc = Fix(Right(Label1.Tag, Len(Label1.Tag) - 1) / 24) + 70006
m = WorksheetFunction.VLookup(Label1.Caption, rooster.Range("b:e"), 4, 0)
.LSkill = Right(m, Len(m) - InStr(1, m, " "))
.StartUpPosition = 0
.Top = X + 10
.Left = Y + 10
.Show
End With
With Label1
If X < .Left Or X > (.Left + .Width) Or Y > (.Top + .Height) Or Y < .Top Then closeee
End With
End If
End Sub
我在第二个用户表单上的代码
Private Sub UserForm_Activate()
Application.OnTime Now + TimeValue("00:00:03"), "closeee"
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
With Me
clearallcontrols
End With
Application.OnTime Now + TimeValue("00:00:03"), "closeee", , False
End Sub
这是加载信息表单时 MAin 用户表单的图片。
此致，
M
你不需要计时...如果你想使用鼠标移动，关闭信息显示表单的代码（我想它的名字是 CurrentJob）应该由 UserForm_MouseMove 主窗体上的事件，因为当离开标签时，鼠标将在窗体本身上移动（除非您将标签彼此相邻放置而没有任何 space - 这将使下一条评论显示为它应该）。
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CurrentJob.Hide
End Sub
我还建议将信息显示代码打包在自己的私有子程序中，以保持各种标签的代码干净。
示例：我有一个包含 Label1、Label2、Label3、Textbox1 和以下代码的表单：
Private Sub ShowInfo(InfoText As String)
' code to query info and show in seperate window
' make sure window doesn't get focus
' I prefer to use non editable text boxes in my main window
Me.TextBox1 = InfoText
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label1"
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label2"
End Sub
Private Sub Label3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label3"
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' this is the exit code
' as here we left all labels
ShowInfo "Mouse is not on a label"
End Sub
这是我在另一个论坛（MrExcel）上得到的答案。所有学分归于 Jaafar Tribak：
1- 标准模块中的代码：
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean
Public Function EnableMouseLeaveEevent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object, Optional ByVal TimeOutInSeconds As Long) As Boolean
Dim oIA As IAccessible
Dim w As Long, h As Long
TargetUserForm.StartUpPosition = 0 '<=== (for testing only .. edit out this line if required)
If bFlag = False Then EnableMouseLeaveEevent = True
Ctrl.Tag = IIf(TimeOutInSeconds > 0, ObjPtr(TargetUserForm) & "*" & TimeOutInSeconds & "*" & Timer, ObjPtr(TargetUserForm))
GetCursorPos tCursPos
#If VBA7 Then
Dim Formhwnd As LongPtr
#If Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tCursPos, LenB(tCursPos)
Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
#Else
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
#Else
Dim Formhwnd As Long
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
WindowFromAccessibleObject MainUserForm, Formhwnd
With tControlRect
oIA.accLocation .Left, .Top, w, h, 0&
.Right = w + .Left
.Bottom = h + .Top
End With
SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Function
Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
Static tPrevCurPos As POINTAPI
Dim tCurrCurPos As POINTAPI
Dim sArray() As String
Dim oCtrolObj As Object, oTargetFormObj As Object
Dim lTimeOut As Long, lStartTimer As Long
CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
sArray = Split(oCtrolObj.Tag, "*")
CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
If UBound(sArray) = 2 Then
lTimeOut = CLng(sArray(1))
lStartTimer = CLng(sArray(2))
End If
GetCursorPos tCurrCurPos
#If VBA7 Then
Dim lngPtr As LongPtr
#If Win64 Then
CopyMemory lngPtr, tCurrCurPos, LenB(tCurrCurPos)
If PtInRect(tControlRect, lngPtr) = 0 Then
#Else
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
#Else
Dim lngPtr As Long
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
bFlag = False
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "Mouse Cursor outside button!"
GoTo Xit
Else
If lTimeOut > 0 Then
With tCurrCurPos
If .x = tPrevCurPos.x And .y = tPrevCurPos.y Then
If Timer - lStartTimer > lTimeOut Then
bFlag = True
lStartTimer = Timer
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "TimeOut!"
End If
Else
bFlag = False
oCtrolObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
GoTo Xit
End If
End With
End If
End If
Xit:
CopyMemory oCtrolObj, 0, LenB(nIDEvent)
CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
GetCursorPos tPrevCurPos
End Sub
2- 用户窗体模块中的代码用法：
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If EnableMouseLeaveEevent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2, TimeOutInSeconds:=5) Then ' 5 Sec timeout
UserForm2.Show
End If
End Sub
这是一个完美的答案。
链接：
VBA- how to have a secondary userform behaviours just like controltiptext
还有一个
Demo Excel File
我有一个带有多个标签控件的用户窗体，它们都属于一个 class，在鼠标悬停时，将显示另一个包含有关该标签的一些信息的用户窗体。现在我希望在鼠标离开控件后关闭该表单。现在我正在使用 application.ontime 并在 2 秒后关闭第二个表单，这使得当鼠标仍在标签上时表单闪烁。我想知道有没有更好的？到目前为止，这是我的代码。
我在 class 模块上的代码
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim m
On Error Resume Next
If Button = XlMouseButton.xlPrimaryButton And LabelBase.Edit.Caption = "Done" Then
Label1.Left = Label1.Left + X - x_offset
Label1.Top = Label1.Top + Y - y_offset
ElseIf LabelBase.Edit.Caption = "Edit" Then
With CurrentJob
.Caption = "Current Job of " & Label1.Caption
.LBcurr.list = openJobs
.LLast = LastJob
.LClsd = WorksheetFunction.CountIfs(oprecord.Range("e:e"), Label1.Caption, oprecord.Range("f:f"), Date, oprecord.Range("s:s"), "CLOSED")
.LAc = Fix(Right(Label1.Tag, Len(Label1.Tag) - 1) / 24) + 70006
m = WorksheetFunction.VLookup(Label1.Caption, rooster.Range("b:e"), 4, 0)
.LSkill = Right(m, Len(m) - InStr(1, m, " "))
.StartUpPosition = 0
.Top = X + 10
.Left = Y + 10
.Show
End With
With Label1
If X < .Left Or X > (.Left + .Width) Or Y > (.Top + .Height) Or Y < .Top Then closeee
End With
End If
End Sub
我在第二个用户表单上的代码
Private Sub UserForm_Activate()
Application.OnTime Now + TimeValue("00:00:03"), "closeee"
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
With Me
clearallcontrols
End With
Application.OnTime Now + TimeValue("00:00:03"), "closeee", , False
End Sub
这是加载信息表单时 MAin 用户表单的图片。
此致，
M
你不需要计时...如果你想使用鼠标移动，关闭信息显示表单的代码（我想它的名字是 CurrentJob）应该由 UserForm_MouseMove 主窗体上的事件，因为当离开标签时，鼠标将在窗体本身上移动（除非您将标签彼此相邻放置而没有任何 space - 这将使下一条评论显示为它应该）。
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CurrentJob.Hide
End Sub
我还建议将信息显示代码打包在自己的私有子程序中，以保持各种标签的代码干净。
示例：我有一个包含 Label1、Label2、Label3、Textbox1 和以下代码的表单：
Private Sub ShowInfo(InfoText As String)
' code to query info and show in seperate window
' make sure window doesn't get focus
' I prefer to use non editable text boxes in my main window
Me.TextBox1 = InfoText
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label1"
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label2"
End Sub
Private Sub Label3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label3"
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' this is the exit code
' as here we left all labels
ShowInfo "Mouse is not on a label"
End Sub
这是我在另一个论坛（MrExcel）上得到的答案。所有学分归于 Jaafar Tribak：
1- 标准模块中的代码：
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean
Public Function EnableMouseLeaveEevent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object, Optional ByVal TimeOutInSeconds As Long) As Boolean
Dim oIA As IAccessible
Dim w As Long, h As Long
TargetUserForm.StartUpPosition = 0 '<=== (for testing only .. edit out this line if required)
If bFlag = False Then EnableMouseLeaveEevent = True
Ctrl.Tag = IIf(TimeOutInSeconds > 0, ObjPtr(TargetUserForm) & "*" & TimeOutInSeconds & "*" & Timer, ObjPtr(TargetUserForm))
GetCursorPos tCursPos
#If VBA7 Then
Dim Formhwnd As LongPtr
#If Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tCursPos, LenB(tCursPos)
Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
#Else
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
#Else
Dim Formhwnd As Long
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
WindowFromAccessibleObject MainUserForm, Formhwnd
With tControlRect
oIA.accLocation .Left, .Top, w, h, 0&
.Right = w + .Left
.Bottom = h + .Top
End With
SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Function
Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
Static tPrevCurPos As POINTAPI
Dim tCurrCurPos As POINTAPI
Dim sArray() As String
Dim oCtrolObj As Object, oTargetFormObj As Object
Dim lTimeOut As Long, lStartTimer As Long
CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
sArray = Split(oCtrolObj.Tag, "*")
CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
If UBound(sArray) = 2 Then
lTimeOut = CLng(sArray(1))
lStartTimer = CLng(sArray(2))
End If
GetCursorPos tCurrCurPos
#If VBA7 Then
Dim lngPtr As LongPtr
#If Win64 Then
CopyMemory lngPtr, tCurrCurPos, LenB(tCurrCurPos)
If PtInRect(tControlRect, lngPtr) = 0 Then
#Else
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
#Else
Dim lngPtr As Long
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
bFlag = False
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "Mouse Cursor outside button!"
GoTo Xit
Else
If lTimeOut > 0 Then
With tCurrCurPos
If .x = tPrevCurPos.x And .y = tPrevCurPos.y Then
If Timer - lStartTimer > lTimeOut Then
bFlag = True
lStartTimer = Timer
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "TimeOut!"
End If
Else
bFlag = False
oCtrolObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
GoTo Xit
End If
End With
End If
End If
Xit:
CopyMemory oCtrolObj, 0, LenB(nIDEvent)
CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
GetCursorPos tPrevCurPos
End Sub
2- 用户窗体模块中的代码用法：
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If EnableMouseLeaveEevent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2, TimeOutInSeconds:=5) Then ' 5 Sec timeout
UserForm2.Show
End If
End Sub
这是一个完美的答案。
链接：
VBA- how to have a secondary userform behaviours just like controltiptext
还有一个 Demo Excel File