Excel VBA-鼠标移动以打开和关闭另一个用户窗体_Excel_Userform_Vba

Excel VBA-鼠标移动以打开和关闭另一个用户窗体

excel vba

Excel VBA-鼠标移动以打开和关闭另一个用户窗体,excel,userform,vba,Excel,Userform,Vba,我有一个带有几个标签控件的userform，它们都属于一个类，在mouseover上，会显示另一个userform，其中包含关于该标签的一些信息。现在我想在鼠标离开控件后关闭该窗体。现在我使用application.ontime并在2秒后关闭第二个表单，这使得当鼠标仍在标签上时表单会闪烁。我想知道是否还有更好的？这是到目前为止我的代码我在类模块上的代码下面是加载信息表单时主用户表单的图片问候，你不需要计时。。。如果您想使用鼠标移动，关闭信息显示窗体的代码（我想它的名称是CurrentJ

我有一个带有几个标签控件的userform，它们都属于一个类，在mouseover上，会显示另一个userform，其中包含关于该标签的一些信息。现在我想在鼠标离开控件后关闭该窗体。现在我使用application.ontime并在2秒后关闭第二个表单，这使得当鼠标仍在标签上时表单会闪烁。我想知道是否还有更好的？这是到目前为止我的代码

我在类模块上的代码下面是加载信息表单时主用户表单的图片

问候，

你不需要计时。。。如果您想使用鼠标移动，关闭信息显示窗体的代码（我想它的名称是

CurrentJob

）应该由主窗体上的

UserForm\u MouseMove

事件触发，因为当离开标签时，鼠标下一步将位于窗体本身上方（除非您将标签放置在彼此相邻的位置，而不留任何空间-这将使下一条注释按其应有的方式显示）

我还建议将信息显示代码打包在自己的私有子组件中，以保持各种标签的代码干净

示例：我有一个带有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）上得到的答案。所有的积分都归贾法尔·特里巴克所有：

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

这是一个完美的答案。链接：

也是

谢谢你的建议，我想当第二个表单被激活（加载）时，鼠标移动没有被主要表单代码记录。我尝试了你的代码，但什么都没有发生。我想我可能需要使用API级别的鼠标移动捕获。我还尝试将表单的模态状态更改为false。但这也是一件愚蠢的事。我不确定我的思维方式有什么问题。我还添加了一个userform的图像n除了其中一个标签外，还加载了信息表单。我的所有标签都是在运行时创建的，并分配给特殊类模块。显示第二个表单后，您可能需要显式地将焦点返回到主表单…到显示第二个表单之前鼠标所在的确切位置…当然，集成会更容易将两个函数都嵌入一个表单是的，我正在将该表单嵌入主用户表单的一个角落。我想我无法将焦点从模块表单移开。无论如何，谢谢。

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    CurrentJob.Hide
End Sub

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

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

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