Option Explicit
Private WithEvents ch As Chart
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 = bTipNames
Application.ShowChartTipValues = bTipValues
End Sub
Private Sub cmbrs_OnUpdate()
Dim tSeriesPointXY As POINTAPI
Dim tCursorPos As POINTAPI
Dim oCol As New Collection
Dim ar() As String
Dim arTemp() As String
Dim oLbl As Control
Dim i As Long
Dim sToolTipAttributes As String
If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
With Application.CommandBars.FindControl(ID:=2040)
.Enabled = Not .Enabled
End With
CopyMemory oCol, CLngPtr(Me.Tag), 8
GetCursorPos tCursorPos
For i = 1 To oCol.Count
sToolTipAttributes = oCol.Item(i)
ar = Split(sToolTipAttributes, "*")
With Sheets(ar(10)).ChartObjects(ar(1))
tSeriesPointXY.x = PTtoPX((.Left + .Chart.SeriesCollection(1).POINTS(ar(0)).Left) * ActiveWindow.Zoom / 100, False) + ActiveWindow.PointsToScreenPixelsX(0)
tSeriesPointXY.y = PTtoPX((.Top + .Chart.SeriesCollection(1).POINTS(ar(0)).Top) * ActiveWindow.Zoom / 100, True) + ActiveWindow.PointsToScreenPixelsY(0)
End With
If Abs(tCursorPos.x - tSeriesPointXY.x) <= 12 And Abs(tCursorPos.y - tSeriesPointXY.y) <= 12 Then
ReDim arTemp(8)
arTemp(0) = ar(2)
arTemp(1) = ar(3)
arTemp(2) = ar(4)
arTemp(3) = ar(5)
arTemp(4) = ar(6)
arTemp(5) = ar(7)
arTemp(6) = ar(8)
arTemp(7) = ar(9)
GoTo XitFor
End If
Next
XitFor:
On Error GoTo xit
If TypeName(ActiveWindow.RangeFromPoint(tCursorPos.x, tCursorPos.y)) = "ChartObject" Then
If Abs(tCursorPos.x - tSeriesPointXY.x) <= 12 And Abs(tCursorPos.y - tSeriesPointXY.y) <= 12 Then
SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
If Not oLbl Is Nothing Then oLbl.Delete
Set oLbl = Me.Controls.Add("Forms.Label.1", "Test", True)
With oLbl
.Caption = arTemp(2): .Left = 0: .Width = arTemp(0): .Height = arTemp(1): .Top = 0
.BackColor = arTemp(7): .Font.Bold = CBool(arTemp(5)): .ForeColor = arTemp(6)
.TextAlign = 2: .Font.Size = arTemp(4):: .Font.Name = arTemp(3) ': .WordWrap = True
End With
Me.Show
MoveWindow hwnd, tSeriesPointXY.x, tSeriesPointXY.y - 10 - PTtoPX(oLbl.Height, True), PTtoPX(oLbl.Width, False), PTtoPX(oLbl.Height, True), True
Else
SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
Me.Hide
End If
Else
SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
Me.Hide
End If
xit:
CopyMemory oCol, 0, 8
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
