Changing shape fill color on mouseover

ebeauchamp28 · Mar 18, 2006

I have a rectangle shape (simple drawing in Excel) that is currently assigned to a macro. When you rest the cursor over, the cursor changes shape to a hand, indicating you can click and activate the macro. However, I would also like the fill color of this rectangle to change temporarily while the cursor is over it.

Any idea of the code required to do this? Would it be needed as a Private Sub?

Many thanks
Erik

ebeauchamp28 · Mar 18, 2006

More info

The following topic seems to be close:

http://www.mrexcel.com/board2/viewtopic.php?t=30108

But it is on open and exit events. If anyone has an extract of code to do something similar on mouseovers, it would be greatly appreciated.

Thanks

Joe Was · Mar 18, 2006

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

'On mouse-over, color Button Green.
If CommandButton1.BackColor <> RGB(122, 255, 0) Then _
CommandButton1.BackColor = RGB(122, 255, 100)
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

'On mouse-over = gone, color Button Red.
If CommandButton1.BackColor <> RGB(255, 0, 0) Then _
CommandButton1.BackColor = RGB(255, 0, 0)
End Sub

Private Sub UserForm_Activate()

'On form open color Button Bright Red.
If CommandButton1.BackColor <> RGB(255, 0, 0) Then _
CommandButton1.BackColor = RGB(255, 0, 0)
End Sub

ebeauchamp28 · Mar 18, 2006

Thanks for the code.

The first part works, but not the second one, when the mouse moves off the button, it does not change color.

I noticed the sub is called:
Private Sub UserForm_MouseMove

Does it mean the button needs to be on a user form? In my document, the button cannot be on a form - it has to be directly on the sheet.

The following topic says that there's no way to capture the "mouse gone" event when the button is not on a form:
http://www.mrexcel.com/board2/viewtopic.php?t=170915

Hopefully there's another workaround...

I've read about using ActiveX controls, but it may add too much complexity for other user of the document.

Legacy 98055 · Mar 19, 2006

You are going to have to resort to some API wizardry and create a hotspot. I don't know how to do that and the following dirty solution may be good enough. Your CPU may scream but DoEvents will yield to other processes and I noticed no problem with performance on my older PC.

The example download contains a class module named, "ShapeEvents" and some code in the thisworkbook class. Sheet1 has a shape named "Rectangle1". See the example download...

ShapeEvents.zip

Class ShapeEvents code:
<table border="1" bgcolor="White"><caption ALIGN=left>Example VBA Code:</caption><tr><td> Option Explicit

 Private Declare Function GetCursorPos Lib "user32" _
 (lpPoint As POINTAPI) As Long ' Declare API

 Private Type POINTAPI ' Declare types
 x As Long
 y As Long
 End Type

 Public Event ShapeEnter(Sh As Shape)
 Public Event ShapeExit(Sh As Shape)

 Private pEnableEvents As Boolean
 Private pPreviousObjectsName As String
 Private pInHover As Boolean
 Private pInHoverShape As Shape
 Private ws As Worksheet

 Public Property Let EnableEvents(Value As Boolean)
 pEnableEvents = Value
 If pEnableEvents Then Tracking
 End Property

 Public Property Get EnableEvents() As Boolean
 EnableEvents = pEnableEvents
 End Property


 Private Sub Tracking()
 Dim pt As POINTAPI
 Dim o As Object
 Dim CurrentObjectsName As String
 'On Error Resume Next
 Do Until Not pEnableEvents
 DoEvents

 GetCursorPos pt
 Set o = ActiveWindow.RangeFromPoint(pt.x, pt.y)


 Select Case TypeName(o)

 Case "Range", "Nothing"
 pPreviousObjectsName = ""
 If pInHover Then
 RaiseEvent ShapeExit(pInHoverShape)
 pInHover = False
 End If

 Case Else
 CurrentObjectsName = o.Name
 If CurrentObjectsName <> pPreviousObjectsName Then
 If pInHover Then RaiseEvent ShapeExit(ws.Shapes(pPreviousObjectsName))
 pPreviousObjectsName = CurrentObjectsName
 Set pInHoverShape = ws.Shapes(CurrentObjectsName)
 RaiseEvent ShapeEnter(pInHoverShape)
 pInHover = True
 End If

 End Select

 Loop

 End Sub

 Private Sub Class_Initialize()
 Set ws = ActiveSheet
 End Sub

 Private Sub Class_Terminate()
 pEnableEvents = False
 End Sub

</td></tr></table>

ThisWorkbook Class Code:
<table border="1" bgcolor="White"><caption ALIGN=left>Example VBA Code:</caption><tr><td> Option Explicit

 Private WithEvents MyShapeEvents As ShapeEvents

 Private Sub MyShapeEvents_ShapeEnter(Sh As Shape)
 Select Case Sh.Name
 Case "Rectangle 1"
 Sh.Fill.ForeColor.SchemeColor = 10
 Sh.TextFrame.Characters.Text = "Click Me!"
 Sh.TextFrame.HorizontalAlignment = xlCenter
 Sh.TextFrame.VerticalAlignment = xlCenter
 With Sh.TextFrame.Characters(Start:=1, Length:=9).Font
 .FontStyle = "Bold"
 .Size = 16
 .Underline = xlUnderlineStyleSingle
 .ColorIndex = 6
 End With
 Sh.Line.Weight = 6#
 Sh.Line.ForeColor.SchemeColor = 40

 'Case "Some Other shape here"

 End Select
 End Sub

 Private Sub MyShapeEvents_ShapeExit(Sh As Shape)
 Select Case Sh.Name
 Case "Rectangle 1"
 Sh.Fill.ForeColor.SchemeColor = 64
 Sh.TextFrame.Characters.Text = ""
 Sh.Line.Weight = 1#
 Sh.Line.ForeColor.SchemeColor = 64
 End Select
 End Sub

 Sub Rectangle1_Click()
 MsgBox "Your macros code here..."
 End Sub

 Private Sub Workbook_Open()
 Set MyShapeEvents = New ShapeEvents
 MyShapeEvents.EnableEvents = True
 End Sub

 Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 Set MyShapeEvents = New ShapeEvents
 MyShapeEvents.EnableEvents = True
 End Sub

 Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
 On Error Resume Next
 MyShapeEvents.EnableEvents = False
 Set MyShapeEvents = Nothing
 End Sub

</td></tr></table>

Legacy 98055 · Mar 19, 2006

Edit the class to disable cell drag and drop or Excel will crash... The downloadable example has these changes reflected within. Also, the code needs some work and may or may not be worth it, but it was fun anyway.

Perhaps this might be more stable using a timer??? Whatdoyu think?

<table border="1" bgcolor="White"><caption ALIGN=left>Example VBA Code:</caption><tr><td> Private Sub Class_Initialize()
 Application.CellDragAndDrop = False
 Set ws = ActiveSheet
 End Sub

 Private Sub Class_Terminate()
 pEnableEvents = False
 Application.CellDragAndDrop = True
 End Sub
</td></tr></table>

Joe Was · Mar 20, 2006

Yes, my code only works on a user form!
Only the UserForm has a Mouse Over Event!
There is no Mouse-Over" Event for a Sheet or ThisWorkbook!

Excel [VBA] has poor Mouse control.

ebeauchamp28 · Mar 20, 2006

Thanks all for your help. Tom, I tried your download and it works nicely, but takes too much CPU. My template sheet has 6 rectangles used as section headers; when you click on them, it automatically expands the grouped subsection. There can be hundreds of sheets based on this template in the same workbook.

I've been able to put a label control under each rectangle, and the mousemove event sets the current rectangle with an orange background, and resets all others to regular blue background. Kind of doing the same effect as the shortcut bar in Outlook. Works okay, but the mouse control is not very accurate. If you move quickly, the mousemove event is not trapped.

I am seriously considering using an activeX control instead, which probably has better mouse control, including a normal "mouse gone" event. Don't know where to start though.

What are the basic steps for this?
Is it a control (shape) I can create myself, then define as ActiveX?
Maybe this area is too technical for me...

If anyone has an Excel sample with such an ActiveX control (mouseover events), thanks in advance for sharing it.

Legacy 98055 · Mar 20, 2006

There is no Mouse_Exit event with the active x controls that come with excel. There is too much overhead involved. I would just use hyperlinks as headers and then respond to user clicks in the Follow_Hyperlink event. There are workarounds using multiple controls but it's not worth it. Especially if you have that many sheets.

Changing shape fill color on mouseover

ebeauchamp28

New Member

ebeauchamp28

New Member

Joe Was

MrExcel MVP

ebeauchamp28

New Member

Legacy 98055

Guest

Legacy 98055

Guest

Joe Was

MrExcel MVP

ebeauchamp28

New Member

Legacy 98055

Guest

Similar threads

Share this page

Changing shape fill color on mouseover

ebeauchamp28

New Member

ebeauchamp28

New Member

Joe Was

MrExcel MVP

ebeauchamp28

New Member

Legacy 98055

Guest

Legacy 98055

Guest

Joe Was

MrExcel MVP

ebeauchamp28

New Member

Legacy 98055

Guest

Similar threads

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock