Hi Phil,
It is still bugging me that it is quicker to call Excel from Access, output
11 charts and link them back to my Access form than it is to create one
chart in Access.
So why not work with Excel, don't know if you can embed an Excel object,
otherwise automate and use the copyPicture approach to maintain chart image
where you need it in Access.
would be interested to see your revised code.
I wonder if you will be after seeing it!
Create an XY scatter or ordinary Line type, play with all the various Axis
options in the Scale tab (X-axis options are different in Scatter vs
non-Scatter), include both +ve & -ve X & Y values
Option Explicit
Sub testGetPointCoords()
Dim i As Long
Dim cht As Chart
Dim arrPoints(), arrColours()
Dim x As Long
'ActiveSheet.Calculate
Set cht = ActiveSheet.ChartObjects(1).Chart
If GetPointCoords(cht, arrPoints) = 0 Then ', 1
' cht.Lines.Delete
x = 24 ' 16 or 24 if automatic colours
For i = LBound(arrPoints) To UBound(arrPoints)
ArrowsToPoints cht, arrPoints(i), srIdx:=i, clrIdx:=x + i
Next
End If
End Sub
Function GetPointCoords(cht As Chart, vPointCoords(), _
Optional nFrom As Long, Optional nTo As Long) As Long
' vPointCoords returns as an array of arrays of XY coords
' nFrom & nTo the series to process
' (if nFrom = 0 get point coords in all series)
' Handles XY scatter and normal Line types on primary axes
' (both X & Y primary axes must exist)
' also handles single 1D column type but
' more to do to cater for multiple columns on the X between labels
' at present all Y's will be right but all X's on or in middle of labels)
Dim bXbetweenCats As Boolean
Dim bCatLabels As Boolean
Dim i As Long, srIdx As Long
Dim nRevX As Long, nRevY As Long ' ReversePlotOrder 1 or -1
Dim axMax As Double, axMin As Double
Dim aX_MaxMin As Double, aY_MaxMin As Double
Dim x0 As Double, y0 As Double ' our co-ord base
Dim xf As Double, yf As Double ' scale factors
Dim xP As Single, yP As Single ' point co-ord
Dim halfCat As Double ' 0 or 0.5
Dim arrX, arrY
Dim sr As Series
Dim aX As Axis, aY As Axis
Dim bDebug As Boolean
bDebug = True
On Error GoTo errH
Set aX = cht.Axes(1)
Set aY = cht.Axes(2)
x0 = aX.Left
y0 = aY.Top + aY.Height
If aX.ReversePlotOrder Then nRevX = -1 Else nRevX = 1
If aY.ReversePlotOrder Then nRevY = -1 Else nRevY = 1
On Error Resume Next
bXbetweenCats = aX.AxisBetweenCategories
If Err.Number <> 0 Then
' must be a scatter (is the definate ?)
On Error GoTo errH
axMax = aX.MaximumScale
axMin = aX.MinimumScale
aX_MaxMin = IIf(nRevX = 1, aX.MaximumScale, aX.MinimumScale)
Else
bCatLabels = True ' not a scatter
axMax = UBound(aX.CategoryNames) - 1
If bXbetweenCats Then
axMax = axMax + 1
halfCat = 0.5 * nRevX
End If
End If
On Error GoTo errH
aX_MaxMin = IIf(nRevX = -1, axMax, axMin)
aY_MaxMin = IIf(nRevY = -1, aY.MaximumScale, aY.MinimumScale)
'scale factor Y
xf = aX.Width / (axMax - axMin)
'scale factor Y
yf = aY.Height / (aY.MaximumScale - aY.MinimumScale)
If bCatLabels Then
' maybe re-adjust aX_MaxMin for the calc in the loop
If nRevX = 1 Then
aX_MaxMin = 1
ElseIf Not bXbetweenCats Then ' And nRevX = -1
aX_MaxMin = aX_MaxMin + 1
End If
End If
If nFrom = 0 Then
nFrom = 1: nTo = cht.SeriesCollection.Count
ElseIf nTo = 0 Then
nTo = nFrom
End If
ReDim vPointCoords(nFrom To nTo)
For srIdx = nFrom To nTo
Set sr = cht.SeriesCollection(srIdx)
With sr
ReDim arrXYcoord(0 To 1, 1 To .Points.Count) As Single
arrX = .XValues
arrY = .Values
If UBound(arrX) < UBound(arrY) Then
Err.Raise 20200, , "Fewer X points than Y points"
End If
For i = 1 To .Points.Count
If bCatLabels Then arrX(i) = i
xP = x0 + (arrX(i) - aX_MaxMin + halfCat) * xf * nRevX
yP = y0 - (arrY(i) - aY_MaxMin) * yf * nRevY
arrXYcoord(0, i) = xP
arrXYcoord(1, i) = yP
Next
End With
vPointCoords(srIdx) = arrXYcoord
Next
Exit Function
errH:
If bDebug Then
If MsgBox(Err.Description & vbCr & "Stop & Resume ?", vbYesNo) _
= vbYes Then
Stop
Resume
End If
Else
MsgBox Err.Description
End If
GetPointCoords = Err.Number
End Function
Function ArrowsToPoints(cht As Chart, aXY, srIdx As Long, _
Optional clrIdx As Long)
' down to right arrows over points
Dim sName As String
Dim sh As Shape
Dim i As Long
Const ARROW_HW As Single = 18
For i = 1 To UBound(aXY, 2)
sName = "S" & srIdx & "_P" & i
On Error Resume Next
Set sh = Nothing
Set sh = cht.Shapes(sName)
On Error GoTo 0
If sh Is Nothing Then
Set sh = cht.Shapes.AddLine(aXY(0, i), aXY(1, i), _
aXY(0, i) - ARROW_HW, aXY(1, i) - ARROW_HW)
sh.Line.BeginArrowheadStyle = msoArrowheadTriangle
sh.Line.EndArrowheadLength = msoArrowheadLengthMedium
sh.Line.EndArrowheadWidth = msoArrowheadWidthMedium
sh.Name = sName
Else
With sh
If Abs(.Left - (aXY(0, i) - ARROW_HW)) > 0.25 Then _
.Left = aXY(0, i) - ARROW_HW
If Abs(.Top - (aXY(1, i) - ARROW_HW)) > 0.25 Then _
.Top = (aXY(1, i) - ARROW_HW)
If Abs(.Width - ARROW_HW) > 0.25 Then .Width = ARROW_HW
If Abs(.Height - ARROW_HW) > 0.25 Then .Height = ARROW_HW
If Not .HorizontalFlip = msoTrue Then _
.Flip msoFlipHorizontal
End With
End If
If clrIdx <> 0 Then
With sh.Line.ForeColor
If .SchemeColor <> 7 + clrIdx Then
.SchemeColor = 7 + clrIdx
End If
End With
End If
Next
On Error Resume Next
For i = i To cht.Shapes.Count
Set sh = Nothing
Set sh = cht.Shapes("S" & srIdx & "_P" & i)
If Not sh Is Nothing Then
sh.Delete
End If
Next
End Function
In this approach XY coordinates may be a few points adrift. A different
earlier approach was a bit more accurate though more work. Main difference
is the above uses entire width & height of the axes as basis for the scale
factors. The other approach only uses to one side of the axes' intersection
point. I suspect the reason is, for say the X-axis, it's more accurate to
define with Y-Axis.left rather than X-Axis.Left which might not be exactly
where anticipated.
Another problem is not reliable with non-100% zoom. It seems a bit odd and
flakey how internal dimensions are returned.
Regards,
Peter T
