The chart in
both cases is a standard xy scatter plot where the plot order of
each data point determines the colour of the marker.
The first chart
sets the data markers colour but due to the limit of the colour
palette it produces a more stepped colouration.
The second chart
uses an autoshape as a custom marker. The colour of the custom
marker is not restricted by the colour palette so the
colouration is smoother.
The code sets
the data markers colour according to the points order within the
data series.
You can specify the start and finish colours and the number of
steps between.
In order for the code below
to work you will need to create 2 charts and insert a autoshape
onto a worksheet. The autoshape should be named Marker.
To name the autoshape select it and enter the new name in the
Name box next to the formula bar.
The code allows you to
specify the start and finish colour of your spectrum. You can
also specify the number of colours to define within the span.
Code module: MSpectrum
Option Explicit
Sub Main()
Dim clsSpectrum As CSpectrum
Set clsSpectrum = New CSpectrum
With clsSpectrum
.Count = 56 ' number of colours in spectrum
.StartColor = RGB(0, 0, 255) ' Blue
.EndColor = RGB(255, 0, 0) ' Red
.CreateSpectrum
End With
UsingMarkers clsSpectrum, ActiveSheet.ChartObjects(1).Chart
UsingCustomMarkers clsSpectrum, ActiveSheet.ChartObjects(2).Chart
End Sub
Sub UsingMarkers(Spectrum As CSpectrum, Cht As Chart)
'
' Using builtin color palette
'
Dim lngIndex As Long
Dim intPoint As Integer
With Cht
With .SeriesCollection(1)
For intPoint = 1 To .Points.Count
lngIndex = intPoint * (Spectrum.Count / .Points.Count)
With .Points(intPoint)
.MarkerBackgroundColor = Spectrum.SpectrumColor(lngIndex)
.MarkerForegroundColor = Spectrum.SpectrumColor(lngIndex)
End With
Next
End With
End With
End Sub
Sub UsingCustomMarkers(Spectrum As CSpectrum, Cht As Chart)
'
' Use a shape as a custom marker
'
Dim shpMarker As Shape
Dim lngIndex As Long
Dim intPoint As Integer
Application.ScreenUpdating = False
Set shpMarker = ActiveSheet.Shapes("Marker")
With Cht
With .SeriesCollection(1)
For intPoint = 1 To .Points.Count
lngIndex = intPoint * (Spectrum.Count / .Points.Count)
shpMarker.Fill.ForeColor.RGB = Spectrum.SpectrumColor(lngIndex)
shpMarker.CopyPicture
.Points(intPoint).Paste
Next
End With
End With
Application.ScreenUpdating = True
End Sub
Class module: CSpectrum
Zilpher Coloured Code
Option Explicit
Private Enum enumSpectrum
Red = 1
Green
Blue
End Enum
Private m_lngStartColor As Long
Private m_lngEndColor As Long
Private m_lngCountColor As Long
Private m_lngSpectrum() As Long
Private m_blnUpdatedSpectrum As Boolean
Public Property Let Count(RHS As Long)
If RHS < 1 Then
m_lngCountColor = 1
ElseIf RHS > 255 Then
m_lngCountColor = 255
Else
m_lngCountColor = RHS
End If
m_blnUpdatedSpectrum = False
End Property
Public Property Get Count() As Long
Count = m_lngCountColor
End Property
Public Sub CreateSpectrum()
'
' Calculate the spread of colours
'
Dim lngIndex As Long
Dim lngColor As Long
Dim sngSpreadRed As Single
Dim sngSpreadGreen As Single
Dim sngSpreadBlue As Single
Dim sngRed As Single
Dim sngGreen As Single
Dim sngBlue As Single
If m_lngCountColor = 0 Then
m_lngCountColor = 2
ReDim m_lngSpectrum(m_lngCountColor) As Long
m_lngSpectrum(1) = m_lngStartColor
m_lngSpectrum(2) = m_lngEndColor
m_blnUpdatedSpectrum = True
End If
ReDim m_lngSpectrum(m_lngCountColor) As Long
m_lngSpectrum(1) = m_lngStartColor
m_lngSpectrum(m_lngCountColor) = m_lngEndColor
sngRed = CSng(m_Color2RGB(m_lngSpectrum(1), Red))
sngGreen = CSng(m_Color2RGB(m_lngSpectrum(1), Green))
sngBlue = CSng(m_Color2RGB(m_lngSpectrum(1), Blue))
For lngIndex = 2 To m_lngCountColor - 1
sngRed = sngRed + sngSpreadRed
sngGreen = sngGreen + sngSpreadGreen
sngBlue = sngBlue + sngSpreadBlue
m_lngSpectrum(lngIndex) = RGB(CInt(sngRed), CInt(sngGreen), CInt(sngBlue))
Next
m_blnUpdatedSpectrum = True
End Sub
Private Function m_Color2RGB(Color As Long, Element As enumSpectrum) As Long
'
' Return RGB element for given color
'
Select Case Element
Case enumSpectrum.Red
m_Color2RGB = Color \ 256 ^ 0 And 255
Case enumSpectrum.Green
m_Color2RGB = Color \ 256 ^ 1 And 255
Case enumSpectrum.Blue
m_Color2RGB = Color \ 256 ^ 2 And 255
End Select
End Function
Public Property Get SpectrumColor(Index As Long) As Long
If Index > m_lngCountColor Then
SpectrumColor = m_lngSpectrum(m_lngCountColor)
ElseIf Index < 1 Then
SpectrumColor = m_lngSpectrum(1)
Else
SpectrumColor = m_lngSpectrum(Index)
End If
End Property
Public Property Let StartColor(RHS As Long)
m_lngStartColor = RHS
m_blnUpdatedSpectrum = False
End Property
Public Property Let EndColor(RHS As Long)
m_lngEndColor = RHS
m_blnUpdatedSpectrum = False
End Property
Public Property Get StartColor() As Long
StartColor = m_lngStartColor
End Property
Public Property Get EndColor() As Long
EndColor = m_lngEndColor
End Property
Private Sub Class_Initialize()
AJP Excel Information
