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