Trigger MouseMove Event on Deselected Charts ?

[Jaafar Tribak]

Hi all,

As you know, worksheet embedded Charts have a MouseMove event which is fired when the mouse is moved over the active, or selected, chart (The event does not fire if the chart is not selected)

This is so messy and counter-intuitive and can cause a number of issues specially screen flickering.

I wonder if there was ever a workaround solution to this problem .. I have looked on the web but couldn't find a solution.

Does anyone know ?

Regards.

Private WithEvents chrt As Chart

Private Sub HookChartEvents()
    Set chrt = Sheet1.ChartObjects(1).Chart
End Sub

Private Sub chrt_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    MsgBox "Mouse Moved Over Chart."
End Sub

 

[Yongle]

Looking good

 

[Jaafar Tribak]

Here is the code that I have arrived at ... It is all encapsulated inside a simple userform module and the actual tooltip that you see is actually this same userform after it has been manipulated with API calls ..

Now the embedded chart no longer requires to be activated in order to fire the mousemove event and there is no screen or worksheet flickerings.

Workbook example

This is the signature of the SUB that takes all the tooltips attributes in its parameters:

Public Sub AddToolTipToChartPoint( _
ByVal Chart As ChartObject, _
ByVal DataPoint As Long, _
ByVal SeriesIndex As Long, _
Optional ByVal ToolTipWidth As Long, _
Optional ByVal ToolTipHeight As Long, _
Optional ByVal ToolTipText As String, _
Optional ByVal ToolTipFontName As String, _
Optional ByVal ToolTipFontSize As Long, _
Optional ByVal ToolTipFontBold As Boolean, _
Optional ByVal ToolTipFontColor As Variant, _
Optional ByVal ToolTipColor As Variant, _
Optional DisplayPointValue As Boolean _
)


1- Add a new blank (no controls in it) userform to your vbproject , name the userform ChartToolTipsCollection and place the following code in its module:

Option Explicit

Private WithEvents cmbrs As CommandBars

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
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

    Private hwnd As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) 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 Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    Private hwnd As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const PointsPerInch = 72
Private Const GWL_STYLE = (-16)
Private Const GCL_STYLE = -26
Private Const GWL_EXSTYLE = (-20)
Private Const WS_CAPTION = &HC00000
Private Const WS_THICKFRAME = &H40000
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const CS_DROPSHADOW = &H20000
Private bTipNames As Boolean, bTipValues As Boolean


Private Sub UserForm_Initialize()
    Me.StartUpPosition = 0
    WindowFromAccessibleObject Me, hwnd
    SetWindowLong hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_CAPTION)
    SetWindowLong hwnd, GWL_EXSTYLE, (GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME)
    MoveWindow hwnd, -20, -20, 10, 10, True
    With Application
        bTipNames = .ShowChartTipNames
        bTipValues = .ShowChartTipNames  '
        .ShowChartTipNames = False
        .ShowChartTipValues = False
    End With
End Sub

Private Sub UserForm_Activate()
    Set cmbrs = Application.CommandBars
    Call cmbrs_OnUpdate
End Sub

Private Sub UserForm_Terminate()
    Application.ShowChartTipNames = True ' bTipNames
    Application.ShowChartTipValues = True ' bTipValues
End Sub

Private Sub cmbrs_OnUpdate()
    Static lCurSerie As Long
    Static lCurDataPoint As Long
    Dim oCol As New Collection
    Dim tSeriesPointXY As POINTAPI
    Dim tCursorPos As POINTAPI
    Dim SerieLineTypes() As Variant
    Dim sArAttributes() As String
    Dim sArTemp() As String
    Dim sToolTipAttributes As String
    Dim i As Long
    Dim bIsLineSerie As Boolean
    Dim oLbl As Control
    Dim ElementID As Long, Arg1 As Long, Arg2 As Long
    
    Dim myX As Variant, myY As Double
    
    If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
       
    With Application.CommandBars.FindControl(ID:=2040)
        .Enabled = Not .Enabled
    End With

    CopyMemory oCol, CLngPtr(Me.Tag), 4
    
    For i = 1 To oCol.Count
        sToolTipAttributes = oCol.Item(i)
        sArAttributes = Split(sToolTipAttributes, "*")
        GetCursorPos tCursorPos
    
        With ThisWorkbook.Sheets(sArAttributes(10)).ChartObjects(sArAttributes(1))
            tCursorPos.X = (tCursorPos.X - ActiveWindow.PointsToScreenPixelsX(0) - PTtoPX((.Left) * ActiveWindow.Zoom / 100, False))
            tCursorPos.Y = (tCursorPos.Y - ActiveWindow.PointsToScreenPixelsY(0) - PTtoPX((.Top) * ActiveWindow.Zoom / 100, True))
            .Chart.GetChartElement tCursorPos.X, tCursorPos.Y, ElementID, Arg1, Arg2
            tSeriesPointXY.X = PTtoPX((.Left + .Chart.SeriesCollection(sArAttributes(11)).POINTS(sArAttributes(0)).Left) * ActiveWindow.Zoom / 100, False) + ActiveWindow.PointsToScreenPixelsX(0)
            tSeriesPointXY.Y = PTtoPX((.Top + .Chart.SeriesCollection(sArAttributes(11)).POINTS(sArAttributes(0)).Top) * ActiveWindow.Zoom / 100, True) + ActiveWindow.PointsToScreenPixelsY(0)
            SerieLineTypes = Array(4, 63, 64, 65, 66, 67, -4101, -4169, 72, 73, 74, 75)
            If Not IsError(Application.Match(.Chart.SeriesCollection(sArAttributes(11)).ChartType, SerieLineTypes, 0)) Then
                bIsLineSerie = True
            End If
        End With
    
        If Arg1 = sArAttributes(11) And Arg2 = sArAttributes(0) Then
            ReDim sArTemp(9)
            sArTemp(0) = sArAttributes(2)
            sArTemp(1) = sArAttributes(3)
            sArTemp(2) = sArAttributes(4)
            sArTemp(3) = sArAttributes(5)
            sArTemp(4) = sArAttributes(6)
            sArTemp(5) = sArAttributes(7)
            sArTemp(6) = sArAttributes(8)
            sArTemp(7) = sArAttributes(9)
            sArTemp(8) = sArAttributes(12)
            Exit For
        End If
    Next i
  
    GetCursorPos tCursorPos
    
    On Error GoTo xit
    
    If TypeName(ActiveWindow.RangeFromPoint(tCursorPos.X, tCursorPos.Y)) = "ChartObject" Then
    
        If Arg1 <> lCurSerie Or Arg2 <> lCurDataPoint Then Me.Hide: GoTo xit
        
        If (ElementID = xlSeries) Then
            If sArTemp(8) Then
                With ThisWorkbook.Sheets(sArAttributes(10)).ChartObjects(sArAttributes(1)).Chart
                    If Arg2 > 0 Then
                        myX = WorksheetFunction.Index(.SeriesCollection(Arg1).XValues, Arg2)
                        myY = WorksheetFunction.Index(.SeriesCollection(Arg1).Values, Arg2)
                        sArTemp(2) = vbCrLf & "Series " & Arg1 & vbCrLf _
                        & """" & .SeriesCollection(Arg1).Name & """" & vbCrLf _
                        & "Point " & Arg2 & vbCrLf _
                        & "X = " & myX & vbCrLf _
                        & "Y = " & myY
                    End If
                End With
            End If
            
            If Not oLbl Is Nothing Then oLbl.Delete
                Set oLbl = Me.Controls.Add("Forms.Label.1", "Test", True)
            With oLbl

                .Caption = sArTemp(2): .Left = 0:  .Width = sArTemp(0): .Height = sArTemp(1): .Top = 0
                .BackColor = sArTemp(7): .Font.Bold = CBool(sArTemp(5)): .ForeColor = sArTemp(6)
                .TextAlign = 2: .Font.Size = sArTemp(4): .Font.Name = sArTemp(3) ': .WordWrap = True
            End With
            Call AddToolTipShadow(hwnd)
            If bIsLineSerie Then
                If Abs(tCursorPos.X - tSeriesPointXY.X) <= 12 And Abs(tCursorPos.Y - tSeriesPointXY.Y) <= 12 Then
                    Me.Show vbModeless
                    MoveWindow hwnd, tSeriesPointXY.X, tSeriesPointXY.Y - 10 - PTtoPX(oLbl.Height, True), PTtoPX(oLbl.Width, False), PTtoPX(oLbl.Height, True), True
                Else
                    Call AddToolTipShadow(hwnd, False)
                    Me.Hide
                End If
            Else 'bIsLineSerie
                Me.Show vbModeless
                MoveWindow hwnd, tSeriesPointXY.X, tSeriesPointXY.Y - 10 - PTtoPX(oLbl.Height, True), PTtoPX(oLbl.Width, False), PTtoPX(oLbl.Height, True), True
            End If 'bIsLineSerie
        Else 'ElementID
            Call AddToolTipShadow(hwnd, False)
            Me.Hide
        End If 'ElementID
    Else 'TypeName
        Call AddToolTipShadow(hwnd, False)
        Me.Hide
    End If 'TypeName
xit:
    CopyMemory oCol, 0, 4
    lCurSerie = Arg1
    lCurDataPoint = Arg2
End Sub


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Sub AddToolTipShadow(ByVal hwnd As LongPtr, Optional ByVal Enable As Boolean = True)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Sub AddToolTipShadow(ByVal hwnd As Long, Optional ByVal Enable As Boolean = True)
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    If Enable = False Then
        SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
    Else
        SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
    End If
End Sub

Private Function PTtoPX(POINTS As Single, bVert As Boolean) As Long
    PTtoPX = POINTS * ScreenDPI(bVert) / PointsPerInch
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
   Static lDPI(1), lDC
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

2- Code usage example :

This example will add some different formatted tooltips to the datapoints depending on the chart series.

Run the LoadToolTips SUb to start and the UnLoadToolTips SUB to finish... These 2 SUBS can be conviniently ran in the WorkbookOpen and BeforeClose events .

In a Standard Module

Option Explicit

Dim oCol As Collection
Dim ChartToolTips As ChartToolTipsCollection

Public Sub LoadToolTips()
    Dim i As Long, j As Long

    For i = 1 To Sheet1.ChartObjects(1).Chart.SeriesCollection.Count
        For j = 1 To Sheet1.ChartObjects(1).Chart.SeriesCollection(i).POINTS.Count
        
            Select Case Sheet1.ChartObjects(1).Chart.SeriesCollection(i).Name
                [B][COLOR=#008000]' Add tooltips for datapoints in series(1)[/COLOR][/B]
                Case Is = "Alpha"
                    Call AddToolTipToChartPoint( _
                        Chart:=ThisWorkbook.Sheets("Sheet1").ChartObjects(1), _
                        DataPoint:=j, _
                        SeriesIndex:=i, _
                        ToolTipWidth:=80, _
                        ToolTipHeight:=80, _
                        ToolTipText:="", _
                        ToolTipFontName:="verdana", _
                        ToolTipFontSize:=10, _
                        ToolTipFontBold:=False, _
                        ToolTipFontColor:=vbWhite, _
                        ToolTipColor:=vbBlack, _
                        DisplayPointValue:=True _
                    )
            
                Case Is = "Beta"
                [B][COLOR=#008000]' Add tooltips for datapoints in series(2)[/COLOR][/B]
                    Call AddToolTipToChartPoint( _
                        Chart:=ThisWorkbook.Sheets("Sheet1").ChartObjects(1), _
                        DataPoint:=j, _
                        SeriesIndex:=i, _
                        ToolTipWidth:=140, _
                        ToolTipHeight:=50, _
                        ToolTipText:="You can add some formatted text here ...", _
                        ToolTipFontName:="Ravie", _
                        ToolTipFontSize:=10, _
                        ToolTipFontBold:=False, _
                        ToolTipFontColor:=vbRed, _
                        ToolTipColor:=vbYellow, _
                        DisplayPointValue:=False _
                    )
                
                Case Is = "Gamma"
                [B][COLOR=#008000]' Add tooltips for datapoints in series(3)[/COLOR][/B]
                    Call AddToolTipToChartPoint( _
                        Chart:=ThisWorkbook.Sheets("Sheet1").ChartObjects(1), _
                        DataPoint:=j, _
                        SeriesIndex:=i, _
                        ToolTipWidth:=80, _
                        ToolTipHeight:=80, _
                        ToolTipText:="", _
                        ToolTipFontName:="Arial", _
                        ToolTipFontSize:=10, _
                        ToolTipFontBold:=False, _
                        ToolTipFontColor:=vbWhite, _
                        ToolTipColor:=vbBlue, _
                        DisplayPointValue:=True _
                    )
               
            End Select
        Next j
    Next i

    ChartToolTips.Show vbModeless

End Sub


Public Sub UnloadToolTips()
    If Not oCol Is Nothing Then UnLoad ChartToolTips: Set oCol = Nothing
End Sub

Public Sub AddToolTipToChartPoint( _
    ByVal Chart As ChartObject, _
    ByVal DataPoint As Long, _
    ByVal SeriesIndex As Long, _
    Optional ByVal ToolTipWidth As Long, _
    Optional ByVal ToolTipHeight As Long, _
    Optional ByVal ToolTipText As String, _
    Optional ByVal ToolTipFontName As String, _
    Optional ByVal ToolTipFontSize As Long, _
    Optional ByVal ToolTipFontBold As Boolean, _
    Optional ByVal ToolTipFontColor As Variant, _
    Optional ByVal ToolTipColor As Variant, _
    Optional DisplayPointValue As Boolean _
)
    
        ToolTipWidth = IIf(ToolTipWidth = 0, 100, ToolTipWidth)
        ToolTipHeight = IIf(ToolTipHeight = 0, 40, ToolTipHeight)
        ToolTipFontName = IIf(ToolTipFontName = "", "Calibri", ToolTipFontName)
        ToolTipFontSize = IIf(ToolTipFontSize = 0, 12, ToolTipFontSize)
        ToolTipFontBold = IIf(ToolTipFontBold = False, False, ToolTipFontBold)
        If IsMissing(ToolTipFontColor) Then ToolTipFontColor = 0
        If IsMissing(ToolTipColor) Then ToolTipColor = &H80FFFF
        

        If oCol Is Nothing Then Set oCol = New Collection: Set ChartToolTips = New ChartToolTipsCollection
        
        oCol.Add DataPoint & "*" & Chart.Name & "*" & ToolTipWidth & "*" & ToolTipHeight & "*" & _
        ToolTipText & "*" & ToolTipFontName & "*" & ToolTipFontSize & "*" & _
        ToolTipFontBold & "*" & ToolTipFontColor & "*" & ToolTipColor & "*" & Chart.Parent.Name & _
        "*" & SeriesIndex & "*" & DisplayPointValue, CStr(oCol.Count + 1)
        ChartToolTips.Tag = CStr(ObjPtr(oCol))
End Sub

Tested only on excel 2010 64bit Win 10 64bit ... I hope it works fine accross different excel editions.

 

[Yongle]

Glad you got it working. Looks like a lot of effort went into that.

 

[Jaafar Tribak]

Glad you got it working. Looks like a lot of effort went into that.

Yongle,

As usual, I see it as a good learning exercise worth the time and effort

BTW, thanks for your interest in this and for your feedbacks.

Regards.

 

[Jaafar Tribak]

I have just tested the code on excel 2007 and it doesn't work .. It errors out on the line :

tCursorPos.X = (tCursorPos.X - ActiveWindow.PointsToScreenPixelsX(0) - PTtoPX((.Left) * ActiveWindow.Zoom / 100, False))

After some investigating, I discovered that this is due to the fact that the Left and Top Properties of the data Point object are not available prior to Office 2010... I found out about this HERE

I am not sure if this issue can somehow be overcome.

On another note, in order for the code to also work on 32 bit office, the following line in the code should be changed from :

CopyMemory oCol, [COLOR=#ff0000]CLngPtr[/COLOR](Me.Tag), 4

To

CopyMemory oCol, [COLOR=#ff0000]CLng[/COLOR](Me.Tag), 4

I have already corrected the line in the downloadable workbook example.

 

[6diegodiego9]

(sorry for resuming this old thread but I found no other threads specific about this problem, that is very interesting to me)

I just tried your demo and unfortunately it crashes my Excel (last version) on the line "CopyMemory oCol, 0, 4".

Two questions:
- how can a collection (oCol) be used as destination argument for CopyMemory, without enclosing it in a ObjPtr instruction? is the ObjPtr implicit here?
- why do you suggest to not use CLngPtr in 32bit Excel, being the LongPtr and CLngPtr introduced (in VBA7) exactly for the purpose to be used in both 32&64bit VBA? (see here)

Do you still use these methods in 2022 or you found better ways?
Thank you very much in advance for sharing your great solutions!