How about this??
It may not be perfect, but it's a start...
#Const DEBUG_CHART = True ' the first time you try this you will probably want to see what's going on...
Public Function Get_ChartObject_ClientCoordinates_Domain() As Boolean
' Author: Logicom (New York)
' Website:
'
' This algorithm uses a quasi-"Battleship" technique to locate the domains
' of the axes used in an Excel Chart.
'
' This information, once calculated, is persisted as a set of "Value Ranges",
' that can subsequently be referenced by a mapping function
' (see Get_ChartXY_from_WindowsXY below),
' which translates "Chart Object Client Coordinates" into Chart Coordinates.
'
' This information could be used to determine the 'true' coordinate context
' for a Chart Mouse Event action for ANY location of the PlotArea that is clicked on
' (presently the GetChartElement function only tells you what is at a location clicked,
' not what is the X, Y coordinate location...),
' OR (better yet) for determining what .Left, .Top, .Width, and .Height values to set
' on Drawing Shapes you add to correctly place them
' relative to Chart X/Y values, to further enhance your Chart (!!)
'
' It is suggested that once these figures are calculated, a Chart's Sheet protection
' be enabled, to circumvent discrepencies in scaling due to a user resizing the Chart
' (though another option would be for this routine to be rerun upon the Chart being resized...)
'
' F.Y.I. We also have an efficient algorithm for sorting cells
' that leaves cell references in formulas being sorted intact
' (an old Excel problem we've never seen solved;
' Excel's standard sort does not have an option to do that
' -the references get altered, relative to the location of the new sorted cells...)
'
Dim ObjectType As Long, ObjectInfo1 As Long, ObjectInfo2 As Long, _
MinX As Long, MaxX As Long, MinY As Long, MaxY As Long, _
X As Long, Y As Long, XbisectGuess As Long, Tries As String
Const MaxYguess As Long = 1000, _
XbisectGuess_Start As Long = 200, _
XbisectGuess_Increment As Long = 100, _
XbisectGuess_Tries As Long = 5, _
MaxXguess As Long = 10000 ' (in Client Coordinates...)
If ActiveChart Is Nothing Then
MsgBox "This function is only meant to be run when a Chart is Active..." & vbCr & _
"(see programming support for assistance)", _
vbExclamation
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' ActiveChart Is Nothing
With ActiveChart
' Example:
' Search for X Axis starting at Chart Object Client Coordinate X=200, 300, 400, 500, 600
' If your XbisectGuess_Start is suited to a spot where the Chart is likely to exist,
' this loop should require only one pass...
Tries = ""
For XbisectGuess = XbisectGuess_Start To XbisectGuess_Start + (XbisectGuess_Tries - 1) * XbisectGuess_Increment Step XbisectGuess_Increment
For MinY = 1 To MaxYguess + 1
.GetChartElement XbisectGuess, MinY, ObjectType, ObjectInfo1, ObjectInfo2
If ObjectType = xlAxis And _
ObjectInfo1 = xlPrimary And ObjectInfo2 = xlCategory _
Then Exit For ' MinY
Next MinY
MinY = MinY - 1
If MinY <= MaxYguess _
Then Exit For ' XbisectGuess
If Tries <> "" _
Then Tries = Tries & ", "
Tries = Tries & XbisectGuess
Next XbisectGuess
If XbisectGuess > XbisectGuess_Start + (XbisectGuess_Tries - 1) * XbisectGuess_Increment Then
MsgBox "Unable to locate X axis" & vbCr & _
"(tried at X=" & Tries & ")", _
vbExclamation, Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' XbisectGuess > XbisectGuess_Start + (XbisectGuess_Tries - 1) * XbisectGuess_Increment
For MinX = 0 To MaxXguess
.GetChartElement MinX, MinY, ObjectType, ObjectInfo1, ObjectInfo2
If ObjectType = xlAxis And _
ObjectInfo1 = xlPrimary And ObjectInfo2 = xlValue _
Then Exit For ' MinX
Next MinX
If MinX > MaxXguess Then
MsgBox "Unable to locate Y axis at Y=" & MinY, vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MinX > MaxXguess
Do
.GetChartElement MinX, MinY, ObjectType, ObjectInfo1, ObjectInfo2
If ObjectType = xlPlotArea _
Then Exit Do ' Loop While MinX <= MaxXguess
MinX = MinX + 1
Loop While MinX <= MaxXguess
If MinX > MaxXguess Then
MsgBox "Unable to locate interior of Y axis", vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MinX > MaxXguess
Y = MinY + 1
For MaxX = MinX + 1 To MaxXguess + 1
X = MaxX + 1
.GetChartElement MaxX, Y, ObjectType, ObjectInfo1, ObjectInfo2
If ObjectType = xlChartArea _
Then Exit For ' MaxX
Next MaxX
MaxX = MaxX - 1
If MaxX > MaxXguess Then
MsgBox "Unable to locate end of X axis", vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MaxX > MaxXguess
If MinX = MaxX Then ' We will get a Divide By 0 on the translation function
MsgBox "X Axis has 0 length!", vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MinX = MaxX
X = MinX - 1
For MaxY = MinY - 1 To 0 Step -1
.GetChartElement X, MaxY, ObjectType, ObjectInfo1, ObjectInfo2
If ObjectType = xlChartArea _
Then Exit For ' MaxY
Next MaxY
MaxY = MaxY + 1
If MaxY < 0 Then
MsgBox "Unable to locate top of Y axis", vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MinY < 0
If MinY = MaxY Then ' We will get a Divide By 0 on the translation function
MsgBox "Y Axis has 0 length!", vbExclamation, _
Title:="Get_ChartObject_ClientCoordinates_Domain"
Get_ChartObject_ClientCoordinates_Domain = False
Exit Function ' Get_ChartObject_ClientCoordinates_Domain
End If ' MinY = MaxY
.Parent.Names.Add .Name & "_MinX", "=" & MinX
.Parent.Names.Add .Name & "_MaxX", "=" & MaxX
.Parent.Names.Add .Name & "_MinY", "=" & MinY
.Parent.Names.Add .Name & "_MaxY", "=" & MaxY
End With ' ActiveChart
#If DEBUG_CHART Then
MsgBox "(" & MinX & ", " & MinY & ") (" & MaxX & ", " & MaxY & ")", _
Title:="Get_ChartObject_ClientCoordinates_Domain"
#End If ' DEBUG_CHART
End Function ' Get_ChartObject_ClientCoordinates_Domain
Private Function Long_RangeValue(ByVal RangeValue As String) As Long
If Left(RangeValue, 1) = "=" _
Then RangeValue = Right(RangeValue, Len(RangeValue) - 1)
Long_RangeValue = Val(RangeValue)
End Function ' Long_RangeValue
Private Function Min(ParamArray Values())
Dim Least, Index As Integer
Least = Values(LBound(Values))
For Index = LBound(Values) + 1 To UBound(Values)
If Values(Index) < Least _
Then Least = Values(Index)
Next Index
Min = Least
End Function ' Min
Private Function Max(ParamArray Values())
Dim Most, Index As Integer
Most = Values(LBound(Values))
For Index = LBound(Values) + 1 To UBound(Values)
If Values(Index) > Most _
Then Most = Values(Index)
Next Index
Max = Most
End Function ' Max
#Const CLOSEST_MATCH = True
Public Function Get_ChartXY_from_WindowsXY(MouseX As Long, MouseY As Long, _
ByRef ChartX As Double, ByRef ChartY As Double, _
Optional RoundX, Optional RoundY _
) As Boolean
' The following is an error factor I have not accounted for;
' anyone can feel free to hunt this down.
' It will require poring over table outputs from the GetChartElement function;
' if somebody wants to pay us well to do that, that's fine too...
Const Epsilon As Double = -0.0035
Dim MinX As Long, MinY As Long, MaxX As Long, MaxY As Long
If ActiveChart Is Nothing Then
MsgBox "This function is only meant to be run when a Chart is Active..." & vbCr & _
"(see programming support for assistance)", _
vbExclamation, Title:="Get_ChartXY_from_WindowsXY"
Get_ChartXY_from_WindowsXY = False
Exit Function ' Get_ChartXY_from_WindowsXY
End If ' ActiveChart Is Nothing
With ActiveChart
On Error GoTo Bad_Values
MinX = Long_RangeValue(.Parent.Names(.Name & "_MinX").Value)
MinY = Long_RangeValue(.Parent.Names(.Name & "_MinY").Value)
MaxX = Long_RangeValue(.Parent.Names(.Name & "_MaxX").Value)
MaxY = Long_RangeValue(.Parent.Names(.Name & "_MaxY").Value)
On Error GoTo 0 ' Restore Error Handler
#If CLOSEST_MATCH Then
MouseX = Max(MinX, MouseX): MouseX = Min(MaxX, MouseX)
MouseY = Max(MinY, MouseY): MouseY = Min(MaxY, MouseY)
#Else ' Not CLOSEST_MATCH
If Not (MinX <= MouseX And MouseX <= MaxX And _
MaxY <= MouseY And MouseY <= MinY _
) _
Then ' You could elect to generate a message that the coordinates are out of bounds;
' this function is designed to be called from a Mouse Event,
' so you can test for the return value of this function and do it there...
Get_ChartXY_from_WindowsXY = False: Exit Function ' Get_WindowsXY_from_ChartXY
End If ' Not in bounds...
#End If ' CLOSEST_MATCH
With .Axes(xlCategory)
ChartX = .MinimumScale + _
(1 + Epsilon) * (MouseX - MinX) * (.MaximumScale - .MinimumScale) _
/ (MaxX - MinX)
End With ' .Axes(xlCategory)
If Not IsMissing(RoundX) _
Then ChartX = Round(ChartX, RoundX)
With .Axes(xlValue)
ChartY = .MinimumScale + _
(1 + Epsilon) * (MinY - MouseY) * (.MaximumScale - .MinimumScale) _
/ (MinY - MaxY)
End With ' .Axes(xlValue)
If Not IsMissing(RoundY) _
Then ChartY = Round(ChartY, RoundY)
Get_ChartXY_from_WindowsXY = True
Exit Function ' Get_ChartXY_from_WindowsXY
Bad_Values: MsgBox "Could not find previously stored Scaling Values..." & vbCr & _
"(see programming support for assistance)", _
vbExclamation, Title:="Get_ChartXY_from_WindowsXY"
Get_ChartXY_from_WindowsXY = False
End With ' ActiveChart
End Function ' Get_ChartXY_from_WindowsXY
Public Function Get_WindowsXY_from_ChartXY(ChartX As Double, ChartY As Double, _
ByRef WindowsX As Long, ByRef WindowsY As Long _
) As Boolean
' The following is an error factor I have not accounted for;
' anyone can feel free to hunt this down.
' It will require poring over table outputs from the GetChartElement function;
' if somebody wants to pay us well to do that, that's fine too...
Const Epsilon As Double = 0.0035
Dim MinX As Long, MinY As Long, MaxX As Long, MaxY As Long
If ActiveChart Is Nothing Then
MsgBox "This function is only meant to be run when a Chart is Active..." & vbCr & _
"(see programming support for assistance)", _
vbExclamation, Title:="Get_WindowsXY_from_ChartXY"
Get_WindowsXY_from_ChartXY = False
Exit Function ' Get_WindowsXY_from_ChartXY
End If ' ActiveChart Is Nothing
With ActiveChart
On Error GoTo Bad_Values
MinX = Long_RangeValue(.Parent.Names(.Name & "_MinX").Value)
MinY = Long_RangeValue(.Parent.Names(.Name & "_MinY").Value)
MaxX = Long_RangeValue(.Parent.Names(.Name & "_MaxX").Value)
MaxY = Long_RangeValue(.Parent.Names(.Name & "_MaxY").Value)
On Error GoTo 0 ' Restore Error Handler
#If CLOSEST_MATCH Then
With .Axes(xlCategory)
ChartX = Max(.MinimumScale, ChartX): ChartX = Min(.MaximumScale, ChartX)
End With ' .Axes(xlCategory)
With .Axes(xlValue)
ChartY = Max(.MinimumScale, ChartY): ChartY = Min(.MaximumScale, ChartY)
End With ' .Axes(xlValue)
#Else ' Not CLOSEST_MATCH
If Not (.Axes(xlCategory).MinimumScale <= ChartX And _
ChartX <= .Axes(xlCategory).MaximumScale And _
.Axes(xlValue).MinimumScale <= ChartY And _
ChartY <= .Axes(xlValue).MaximumScale _
) _
Then ' You could elect to generate a message that the coordinates are out of bounds
Get_WindowsXY_from_ChartXY = False: Exit Function ' Get_WindowsXY_from_ChartXY
End If ' Not in bounds...
#End If ' CLOSEST_MATCH
With .Axes(xlCategory)
WindowsX = Round(MinX + _
(1 + Epsilon) * (ChartX - .MinimumScale) * (MaxX - MinX) _
/ (.MaximumScale - .MinimumScale), _
0 _
)
End With ' .Axes(xlCategory)
With .Axes(xlValue)
WindowsY = Round(MaxY - _
(1 + Epsilon) * (ChartY - .MinimumScale) * (MinY - MaxY) _
/ (.MaximumScale - .MinimumScale), _
0 _
)
End With ' .Axes(xlValue)
Get_WindowsXY_from_ChartXY = True
Exit Function ' Get_Windows_XY_From_ChartObject
Bad_Values: MsgBox "Could not find previously stored Scaling Values..." & vbCr & _
"(see programming support for assistance)", _
vbExclamation, Title:="Get_WindowsXY_from_ChartXY"
Get_WindowsXY_from_ChartXY = False
End With ' ActiveChart
End Function ' Get_WindowsXY_from_ChartXY
#If DEBUG_CHART Then
Public Sub Run_Get_ChartObject_ClientCoordinates_Domain()
' A stub for calling the function Get_ChartObject_ClientCoordinates_Domain
' for testing purposes...
Get_ChartObject_ClientCoordinates_Domain
End Sub ' Run_Get_ChartObject_ClientCoordinates_Domain
#End If ' DEBUG_CHART
' EXAMPLES OF USING THESE FUNCTIONS:
'
' In a Class Module that loads a Mouse Event Function for a Chart,
' you could have something like this:
''Public WithEvents MyChart_Class As Chart
''
''Private Sub MyChart_Class_MouseUp(ByVal Button As Long, ByVal Shift As Long, _
'' ByVal X As Long, ByVal Y As Long _
'' )
''Dim ChartX As Double, ChartY As Double
''
''If Get_ChartXY_from_WindowsXY(X, Y, ChartX, ChartY, 0, 0) _
'' Then MsgBox ChartX & ", " & ChartY, Title:="MyChart_Class_MouseUp"
''End Sub ' MyChart_Class_MouseUp
'
' EXAMPLE 2:
'
''Const HighlighterYellow As Long = 43, _
'' Translucent As Double = 0.5
''
''Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, Box
''
''If Get_WindowsXY_from_ChartXY(50, 1, X1, Y1) And _
'' Get_WindowsXY_from_ChartXY(100, 2, X2, Y2) Then
'' ' Overlay a box ranging from X Chart coordinates 50 to 100, and Y coordinates 1 to 2...
'' ' (make it translucent so we can see SeroesPoints under it!)
'' Set Box = ActiveChart.Shapes.AddShape(msoShapeRectangle, _
'' X1, Y2, X2 - X1, Y2 - Y1 _
'' ) ' Left, Top, Width, Height
'' With Box.ShapeRange.Fill
'' .Visible = msoTrue: .Solid
'' .ForeColor.SchemeColor = HighlighterYellow
'' .Transparency = Translucent
'' End With ' Box.ShapeRange.Fill
'' Set Box = Nothing ' Deallocate...
''End If ' Get_WindowsXY_from_ChartXY
![[flowerface]](/data/assets/smilies/flowerface.gif "[flowerface] [flowerface]")
![[swords]](/data/assets/smilies/swords.gif "[swords] [swords]")
