Help with MouseMove Events for ActiveX controls on a Worksheet

[Hamburgler]

A couple of issues.

I want to use the MouseMove event on ActiveX labels on a worksheet to change the BackColor of the labels while the cursor is over the labels.

I have had some success by using another background label to detect when the cursor leaves the target label and change the color back.

Private Sub TargetLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
TargetLabel.BackColor = RGB(0, 255, 0)
End Sub

Private Sub LabelFrame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
TargetLabel.BackColor = RGB(255, 0, 0)
End Sub

The problem is:

First, detection does not always work properly, especially if the mouse is moved quickly. Is there a way around this.

Second, When the user left clicks on the background label it becomes visible and is moved to the front of the main label temporarily until the cursor is moved off it. I have set the BackStyle property to transparent – and tried a few other things, but cannot prevent this.

Any help would be appreciated.

 

[Jaafar Tribak]

Hi . what you need is a kind of MouseLeave event which doesn't exist.

Here is a workaround hack that i tested and works very well ! WORKBOOK DEMO.

Place this on the worksheet module ie: where the Label (TargetLabel) is embeeded :

Option Explicit
 
Private Type POINTAPI
    X As Long
    Y As Long
End Type
 
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) 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 lTimerId As Long
 
Private Sub TargetLabel_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
 
    TargetLabel.BackColor = RGB(0, 255, 0)
    KillTimer 0, lTimerId
    lTimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
 
End Sub

Public Sub Delegated_TimerProc()
    Dim tP As POINTAPI
    
    On Error Resume Next
    
    GetCursorPos tP
    
    If ActiveWindow.RangeFromPoint(tP.X, tP.Y).Name <> "TargetLabel" Then
        Sheets(1).TargetLabel.BackColor = RGB(255, 0, 0)
        KillTimer 0, lTimerId
    End If

End Sub

and place this in a Standard Module :

Option Explicit
 
Sub TimerProc()
 
 Call Sheets(1).Delegated_TimerProc
 
End Sub

Should work even with fast mouse moves.

Regards.

 

[Hamburgler]

Thanks Jaafar, I just had a look at the example file it it looks excellent.

I will integrate it into my .XLSB file tonight and let you know how I go.

Cheers,

 

[Hamburgler]

The code works well for a single label but I have not been successful in adapting it to deal with multiple labels. For the project I am working on I was hoping to have maybe 5 labels on a single sheet.

I tried the following code but it does not behave how I hoped. This code is a few steps ahead of where I am at the moment.

Please help me again.

Private Type POINTAPI
    X As Long
    Y As Long
End Type
 
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) 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 lTimerId As Long
 
Private Sub TargetLabel1_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
 
    TargetLabel1.BackColor = RGB(0, 255, 0)
    KillTimer 0, lTimerId
    lTimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
 
End Sub

Private Sub TargetLabel2_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
 
    TargetLabel2.BackColor = RGB(0, 255, 0)
    KillTimer 0, lTimerId
    lTimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
 
End Sub

Public Sub Delegated_TimerProc()
    Dim tP As POINTAPI
    
    On Error Resume Next
    
    GetCursorPos tP
    
    If ActiveWindow.RangeFromPoint(tP.X, tP.Y).Name <> "TargetLabel1" Then
        Sheets(1).TargetLabel1.BackColor = RGB(255, 0, 0)
        KillTimer 0, lTimerId
    End If
    If ActiveWindow.RangeFromPoint(tP.X, tP.Y).Name <> "TargetLabel2" Then
        Sheets(1).TargetLabel2.BackColor = RGB(255, 0, 0)
        KillTimer 0, lTimerId
    End If

End Sub

 

[Hamburgler]

OK I have spent hours trying to work out how to do this. The monstrosity in the code box below is where I am currently at. The event handling works fine – but the CPU runs permanently at >50% and there are other assorted issues (like Excel crashing) that make it unusable.

To Reiterate: I want to use ActiveX Labels (Maybe 5) on a worksheet that have event handling like JavaScript On-Mouse-Over and On-Mouse-Out. (I can't write them in here).

I shall keep slogging away – It is a good learning experience – but if anyone knows a simpler way to do it – or can even point me in the right direction – I would really appreciate it.

I am using Excel 2007 on Windows 7 if that helps.


Workbook module

Private Sub Workbook_Open()
    Call Sheets(1).MouseMove
End Sub

Sheet1 Module

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Sub MouseMove()
    Dim lngCurPos As POINTAPI
    Dim DocZero As POINTAPI
    Dim PointsPerPixelY As Double
    Dim PointsPerPixelX As Double
    Dim hdc As Long
        hdc = GetDC(0)
        PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
        PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
        ReleaseDC 0, hdc
        DocZero.Y = ActiveWindow.PointsToScreenPixelsY(0)
        DocZero.X = ActiveWindow.PointsToScreenPixelsX(0)
    Do
        On Error Resume Next
            GetCursorPos lngCurPos
            X = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY
            Y = (lngCurPos.X - DocZero.X) * PointsPerPixelX
            DoEvents

            If (X < A.Top Or X > A.Top + A.Height) Or (Y < A.Left Or Y > A.Left + A.Width) Then
                A.BackColor = RGB(0, 0, 255)
            Else
                A.BackColor = RGB(255, 0, 0)
            End If

            If (X < B.Top Or X > B.Top + B.Height) Or (Y < B.Left Or Y > B.Left + B.Width) Then
                B.BackColor = RGB(0, 0, 255)
            Else
                B.BackColor = RGB(255, 0, 0)
            End If
        On Error GoTo 0
    Loop
End Sub

 

[Hamburgler]

I think that I got it. I'm sure that there is a more elegant way to to this. Any comments would be welcome. I will report back if it turns out not to work as expected.


Worksheet module

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Sub A_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    A.BackColor = RGB(255, 0, 0)
    Call MouseMove
End Sub

Private Sub B_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    B.BackColor = RGB(255, 0, 0)
    Call MouseMove
End Sub

Sub MouseMove()
    Dim lngCurPos As POINTAPI
    Dim DocZero As POINTAPI
    Dim PointsPerPixelY As Double
    Dim PointsPerPixelX As Double
    Dim hdc As Long
        hdc = GetDC(0)
        PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
        PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
        ReleaseDC 0, hdc
        DocZero.Y = ActiveWindow.PointsToScreenPixelsY(0)
        DocZero.X = ActiveWindow.PointsToScreenPixelsX(0)
    Do
            GetCursorPos lngCurPos
            X = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY
            Y = (lngCurPos.X - DocZero.X) * PointsPerPixelX
            DoEvents
' +++++++++ MOUSE NOT OVER A
            If (X < A.Top Or X > A.Top + A.Height) Or (Y < A.Left Or Y > A.Left + A.Width) Then
                A.BackColor = RGB(0, 0, 255)
                NotA = 1
            End If
' +++++++++ MOUSE NOT OVER B
            If (X < B.Top Or X > B.Top + B.Height) Or (Y < B.Left Or Y > B.Left + B.Width) Then
                B.BackColor = RGB(0, 0, 255)
                NotB = 1
            End If
            If NotA = 1 And NotB = 1 Then Exit Do
    Loop
End Sub

 

[Legacy 134911]

http://cid-ea73b3a00e16f94f.skydrive.live.com/self.aspx/Mr Excel Example/FrameHotTracker.zip

Another approach using frames. This is a most basic example using one control. If you wish to add more than a few controls, then you should place this code in a custom class, create instances of your class, and use callbacks to the worksheet. The neat think about this method is it uses ranges. You can also use pictures saved to file or even autoshapes. I have a more extensive example if this one interests you. Have a good one! ~ Tom ~