none
Mouseover event on shapes (Excel 2003)

    Question

  • Can I set a mouseover event in VBA on a shape (copied picture)?

     

    I have a module that copies an inserted image from one sheet to another sheet based on cell values denoting the placement of the copied image.

     

    The copy is then handled as a shape to set Name, Alt Text, and so on and the sheet is saved as a web page for browser viewing.

     

    Is there a way to set a mouseover event for a Shape object so that when someone points at the image on the web page, the image changes?

     

    Code Snippet
        ' Go to the Display sheet and paste the copied image into the cell referenced
           
            Sheet1.Activate
            Sheet1.Range(pRange).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
                               
        ' Set the AltText and Name to match the server network name
       
            Sheet1.Shapes(Sheet1.Shapes.Count).Name = sRange & "-" & namePicture
           
            Sheet1.Shapes(Sheet1.Shapes.Count).AlternativeText = namePicture
       
        ' Format picture by calling washPicture() from module3
               
            washPicture
       
        ' Put the picture name in the cell one over to the left and hyperlink it
       
       
            ActiveCell.Offset(0, -1).Range("A1").Select
            ActiveCell.FormulaR1C1 = namePicture
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                namePicture, TextToDisplay:=namePicture

     


         

    Saturday, May 12, 2007 11:18 AM

Answers

  • Excel's Shape object exposes no events to the object model, so your code cannot detect a mouseover.

    - Jon
    -------
    Jon Peltier, Microsoft Excel MVP
    Tutorials and Custom Solutions
    http://PeltierTech.com
    _______
    Saturday, May 12, 2007 4:35 PM

All replies

  • Excel's Shape object exposes no events to the object model, so your code cannot detect a mouseover.

    - Jon
    -------
    Jon Peltier, Microsoft Excel MVP
    Tutorials and Custom Solutions
    http://PeltierTech.com
    _______
    Saturday, May 12, 2007 4:35 PM
  • if you use the timer to look at the mouse pointer every small time (.2 sec) and then find the

    object at the cursor then you can find the object. ( shape , chart range etc)

    If you use a onclick macro from the shape and do events waiting for next click then you can get  1 ,2 ,3 .. n clicks countef for the mouse

    for the mouse over this in a code module

    [code]

    Option Explicit: Option Compare Text
    ' Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI)
    Declare Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
    Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

    Declare Function SetCursorPos& Lib "user32" (ByVal x&, ByVal Y&)
    Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags&, ByVal dx&, ByVal dy&, ByVal cButtons&, ByVal dwExtraInfo&)
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds&)

    Public Type POINTAPIxx
        x As Long
        Y As Long
    End Type
    Dim wPtA As POINTAPI, wPyB As POINTAPI


    Public rot%, LastX&, LastY&, LastC&
    Public hwnd&, uMsg&, nIDEvent&, dwTimer&, TimerID&


    Public Declare Function SetTimer Lib "user32" ( _
                                     ByVal hwnd As Long, _
                                     ByVal nIDEvent As Long, _
                                     ByVal uElapse As Long, _
                                     ByVal lpTimerFunc As Long) As Long

    Public Declare Function KillTimer Lib "user32" ( _
                                      ByVal hwnd As Long, _
                                      ByVal nIDEvent As Long) As Long
    Public TimerSeconds As Single

    Sub StartTimera()
        TimerSeconds = 0.2   ' how often to "pop" the timer.
        TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf WhatShapea)
    End Sub

    Sub StopTimerA()
        On Error Resume Next
        KillTimer 0&, TimerID
    End Sub
    Sub WhatShapea()
        Dim pt As POINTAPI, OB As Object, ShC As shape
      'StopTimerA
       DoEvents
       On Error GoTo getbad:
      
        GetCursorPos pt
        Cells(1, 10) = pt.x
       
        If Not ActiveWindow.RangeFromPoint(pt.x, pt.Y) Is Nothing Then
        Set OB = ActiveWindow.RangeFromPoint(pt.x, pt.Y)
        ' Range("a1:g9").ClearContents
       
        If Not OB Is Nothing Then
            ObjTypeNa = TypeName(OB)


            ' On Error GoTo outit
            '     Cells(4, 4) = .Top
            Cells(5, 4) = TypeName(OB)
            If TypeName(OB) = "Range" Then
                FixBackColor
                Cells(5, 6) = OB.Address
            Else
                Cells(5, 8) = ActiveSheet.Shapes(OB.Name).Type
                Cells(7, 4) = ActiveSheet.Shapes(OB.Name).AutoShapeType
                Cells(6, 4) = OB.Name
                Cells(8, 4) = ObjTypeNa
               
                Select Case ObjTypeNa
                    Case "Rectangle", "Drawing", "ChartObject"
                        If OB.Name <> LastShNa Then    ' new object
                            FixBackColor
                            ' get new shapes values
                            LastShCo = ActiveSheet.Shapes(OB.Name).Fill.ForeColor.RGB
         
                            ActiveSheet.Shapes(OB.Name).Fill.ForeColor.RGB = Int(Rnd() * 250 * 200 + 60)    ' RGB(146, 2, 80)
                            WasOleObj = False
                        End If

                    Case "Oleobject"
                        'ActiveSheet.OLEObjects("bert").Object.BackColor = vbBlue
                        If OB.Name <> LastShNa Then    ' new object
                            FixBackColor
                            Cells(1, 3) = OB.Name
                           
                            ' get new object  values
                            LastShCo = ActiveSheet.OLEObjects(OB.Name).Object.BackColor
                            ActiveSheet.OLEObjects(OB.Name).Object.BackColor = Int(Rnd() * 2500200)     ' RGB(146, 2, 80)
                            WasOleObj = True
                        End If
                End Select

                If LastShNa = OB.Name Then   ' is still over the same object
                    CountHovers = CountHovers + 1
                     If CountHovers > 12 Then    ' change number for  hover length 'now 1.2 sec
                        'put here whatever function you want on hovering
                   Cells(3, 2) = "hover"
                    Cells(3, 3) = OB.Name
                    Cells(3, 4) = CountHovers
                    End If
                Else
                    CountHovers = 0
                     Cells(3, 2) = "not hovering yet"
                    Cells(3, 3) = OB.Name
                    Cells(3, 4) = CountHovers
                
                End If
                LastShNa = OB.Name
                GotOneShape = True
                'outit: ' for on error
            End If
        End If
    End If
    Cells(1, 11) = Timer
    Cells(1, 12) = StopTime
    getbad:

        If Timer > StopTime Then StopTimerA
       '     StartTimera
        'Else
       
          '  FixBackColor
        'End If

    End Sub

     

    [/code]

    a few shapes autoshapes freeforms charts on a worksheet

    some command buttons as

    [code]

    Private Sub CommandButton2_Click()
     GotOneShape = False
        CountHovers = 0
    StopTime = Timer + 12  ' 12 sec..
    'timer in seconds  time as in Now is in days
    StartTimera

    End Sub

    Private Sub CommandButton3_Click()
    StopTimerA

    End Sub

    [/code]

    and you have mouse over , mouse hover , mouse leave evants for shapes


    farmer

    Friday, November 30, 2012 10:41 AM
  • That looks like a great solution Harry but can you help me to understand waht to do with it.

    I am using several labels with a shape behind it grouped together and being used as a button . 

    I need to be able to triger a hover event and and click event.

    Thursday, January 10, 2013 10:08 PM