mouseover shape

[kuranzi]

im new on vba guys.. i wanna ask, hot to add mouseover effect colour on that shape (when i move my mouse there the colour change to white or something) can someone help me how to do that step by step.. thanks before

 

[Yongle]

Shapes do not have mousemove events, but active-x objects do.
The workaround is to add 2 active-x labels and use their respective mousemove events to change the shape's colour. Both labels sit behind the shape. Label2 is bigger than Label1, Label1 is bigger than the shape. Label2 mousemove sets shape default colour. Label2 mousemove sets hover-over colour.

Method - Try this in a NEW workbook first to practice the method

1. Insert a shape - use the first Rectangle - expect it to be auto-named "Rectange 1"

2. On Developer's tab
- Insert (Active-X) Label
- click on worksheet (away from rectangle) to insert it (expect this to be auto-named Label1) and make it larger than the shape
- Insert (Active-X) Label
- click on worksheet to insert it (expect this to be auto-named Label2) and make it larger than Label1
- click on sheet tab \ View Code \ paste code below into VBA window

Private Sub [COLOR=#000080]Label1[/COLOR]_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'a red colour
    ActiveSheet.Shapes("[COLOR=#ff0000]Rectange 1[/COLOR]").Fill.ForeColor.RGB = RGB(192, 0, 0)
End Sub

Private Sub [COLOR=#000080]Label2[/COLOR]_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'a blue colour
    ActiveSheet.Shapes("[COLOR=#ff0000]Rectangle 1[/COLOR]").Fill.ForeColor.RGB = RGB(0, 32, 96)
End Sub

3. {ALT} {F11} takes you back to workbook

4. Switch off Design Mode (by clicking on the Design Mode button)

5. Hover mouse over both labels - move to step6 only the shape's colour is changed by both

6. Switch on Design Mode

7. Move Label1 over top of shape \ right-click \ Order \ Send-To-Back

8. Right-click on Label1 \ Properties \ amend BackStyle to Transparent & delete text in Caption

9. Repeat for Label2

10. Use {CTRL} to select all 3 objects \ right-click \ Group \ Group (all can now be moved together)

11. Switch off Design Mode and test

After testing, adapt for live workbook amending the values to suit your own requirements (Shape name is different, Label names may be different, colour choice etc)

Let me know how you get on

 

[Jaafar Tribak]

Alternatively, you could use this code :

In the ThisWorkbook Module: (Run the Workbook_Open event code to take effect)

The code below applies to the shape named Shape1 located on Worksheets(1) .. Change these in the Shape_MouseEnter and Shape_MouseLeave pseudo-events as required

Option Explicit

Private Type POINTAPI
        x As Long
        y As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private WithEvents CmndBrarsEvent As CommandBars
Private oPrevShape As Shape
Private lInitialColor As XlRgbColor

Private Sub Workbook_Open()
    Set CmndBrarsEvent = Application.CommandBars
    ActiveWindow.RangeSelection.Select
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not oPrevShape Is Nothing Then Shape_MouseLeave oPrevShape
End Sub

Private Sub CmndBrarsEvent_OnUpdate()
    Static oPrevShape As Shape
    Dim tPt As POINTAPI
    Dim oShape As Shape
    
    On Error Resume Next
    GetCursorPos tPt
    Set oShape = ActiveSheet.Shapes(ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Name)
    If Not oShape Is Nothing And (oPrevShape Is Nothing) Then
        On Error GoTo 0
        Call Shape_MouseEnter(oShape)
        GoTo Xit
    End If
    If Not oShape Is Nothing Then
        On Error GoTo 0
        Call Shape_MouseMove(oShape, tPt.x, tPt.y)
        GoTo Xit
    End If
    If oShape Is Nothing And Not (oPrevShape Is Nothing) Then
        On Error GoTo 0
        Call Shape_MouseLeave(oPrevShape)
    End If
Xit:
    If TypeName(Selection) = "Range" Then
       ActiveWindow.RangeSelection.Select
    End If
    Set oPrevShape = oShape
End Sub

[B][COLOR=#008000]'=====================
'Mouse events handlers.
'=====================[/COLOR][/B]
Private Sub Shape_MouseEnter(ByVal Shape As Shape)
    With Shape
        If .Parent Is Worksheets(1) And Shape.Name = "Shape1" Then [B][COLOR=#008000]'<== Change sheet and shape names as required.[/COLOR][/B]
            lInitialColor = .Fill.ForeColor.RGB
            .Fill.ForeColor.RGB = vbRed
        End If
    End With
End Sub

Private Sub Shape_MouseLeave(ByVal Shape As Shape)
    With Shape
        If Shape.Parent Is Worksheets(1) And Shape.Name = "Shape1" Then [B][COLOR=#008000]'<== Change sheet and shape names as required.[/COLOR][/B]
            .Fill.ForeColor.RGB = lInitialColor
        End If
    End With
End Sub

Private Sub Shape_MouseMove(ByVal Shape As Shape, ByVal MouseX As Long, MouseY As Long)
    [B][COLOR=#008000]' add some mousemove code here...[/COLOR][/B]
End Sub

 

[kuranzi]

so many thanks senpai, ill learn vba now, ill try this code, so many thanks guys :D

 

[kuranzi]

i already try 1 night, but the colour when i enter is not change, maybe i miss something, u guys have video tutorial ? thanks before guys :D

 

[Yongle]

Watch this video - it is very similar to solution in post#2