Search code examples
exceluserformvba

VBA- MouseMove to open and close another userform

I have a userform with several label controls, all belong to a class that on mouseover, another userform containing some information about that label will be shown. Now I wanted that form to be closed after mouse leaves the control. Now I am using application.ontime and closing the second form after 2 seconds, which makes the form flickers when the mouse is still over the label. I am wondering if there is anyway better? Here is my code so far.

My Code on the class Module

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

My code on the second userform

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

Here is a picture of MAin userform when the Info Form is loaded.

Information_form_Partial.jpg

Regards,
M

Solution

  • Here is the Answer I got on another forum (MrExcel). All the credits go to Jaafar Tribak:

    1- Code in a Standard module:

    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- Code usage in UserForm Module:

    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

    Thats was a perfect answer. Links:
    VBA- how to have a secondary userform behaviours just like controltiptext

    Also a Demo Excel File