Help with MouseMove Events for ActiveX controls on a Worksheet

H

Hamburgler

Board Regular
Joined
May 16, 2009
Messages
148
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.

Code: 
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.
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
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 :

Code: 
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 :

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

Should work even with fast mouse moves.

Regards.
 
Upvote 0
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,
 
Upvote 0
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.

Code: 
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
 
Upvote 0
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
Code: 
Private Sub Workbook_Open()
    Call Sheets(1).MouseMove
End Sub

Sheet1 Module
Code: 
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
 
Upvote 0
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
Code: 
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
 
Upvote 0
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 ~
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
134
6StringJazzer
6StringJazzer
G
  • Solved
Run-Time Error 381
2
Replies
12
Views
271
Micron
M
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
S
  • Question Question
Userform button click
Replies
1
Views
298
SQUIDD
S
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
389
Minh Tuan VN
M

Forum statistics

Threads
1,225,149
Messages
6,183,194
Members
453,151
Latest member
Lizamaison

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top