Private Sub Form_Current()
Dim chtObj As Object, strRowSource As String
Dim rsRowSourceFiltered As Recordset
Dim intMaxShippers As Integer
Dim i As Integer, j As Integer
Dim strArrShipperNames() As String
Dim intArrShipperColors() As Integer
' The color integers are those that are used
' by the QBColor function to assign point colors.
Const cFederal_Blue = 1
Const cSpeedy_Green = 2
Const cUnited_Red = 4
intMaxShippers = 3
' Place all the shipper name values
' into an array.
ReDim strArrShipperNames(intMaxShippers)
strArrShipperNames(1) = "Federal Shipping"
strArrShipperNames(2) = "Speedy Express"
strArrShipperNames(3) = "United Package"
' Place the shipper color values
' into an array.
ReDim intArrShipperColors(intMaxShippers)
intArrShipperColors(1) = cFederal_Blue
intArrShipperColors(2) = cSpeedy_Green
intArrShipperColors(3) = cUnited_Red
Set chtObj = Me!chtColorChart.Object
' In the chart's RowSource, insert a WHERE
' clause based on the value of the form
' field contained in the chart control's
' LinkMasterFields property.
strRowSource = Left(Me!chtColorChart.RowSource, _
InStr(Me!chtColorChart.RowSource, "GROUP BY") - 1) _
& "WHERE " & Me!chtColorChart.LinkChildFields & _
" = '" & Me(Me!chtColorChart.LinkMasterFields) & _
"'" & " " & Right(Me!chtColorChart.RowSource, _
Len(Me!chtColorChart.RowSource) _
- InStr(Me!chtColorChart.RowSource, "GROUP BY") + 1)
Set rsRowSourceFiltered = CurrentDb. _
OpenRecordset(strRowSource, dbOpenSnapshot)
' Check to see if the filtered recordset has any records.
If rsRowSourceFiltered.BOF And _
rsRowSourceFiltered.EOF Then
MsgBox "There are no records to chart."
Exit Sub
End If
' Clear the rows required for the maximum number of
' data rows. The first row contains the column
' headers. Data rows being at the second row.
With chtObj.Application.DataSheet
For i = 1 To intMaxShippers
.Rows(i + 1).Include = False
Next
End With
' Ensure the RecordCount value is updated.
rsRowSourceFiltered.MoveLast
' Populate the chart's datasheet with the
' filtered recordset, starting with the
' datasheet's second row.
rsRowSourceFiltered.MoveFirst
For i = 1 To rsRowSourceFiltered.RecordCount
For j = 0 To rsRowSourceFiltered.Fields.Count - 1
' Assign data to the datasheet cells starting
' at row 2, column 1.
chtObj.Application.DataSheet. _
Cells(i + 1, j + 1).Value = _
rsRowSourceFiltered.Fields(j).Value
Next
rsRowSourceFiltered.MoveNext
Next
' Loop through the recordset containing
' the chart's filtered RowSource.
rsRowSourceFiltered.MoveFirst
i = 0
While Not rsRowSourceFiltered.EOF
' Index i synchronizes the Points collection
' index with the current recordset row.
i = i + 1
' Loop through the shipper names array and look
' for a match with the field names of the chart's
' filtered RowSource.
For j = 1 To UBound(strArrShipperNames) ' 1-based
' The first field in the recordset contains
' the shipper name. Some shippers may not
' be in the filtered recordset.
If rsRowSourceFiltered.Fields(0).Value _
= strArrShipperNames(j) Then
' Because every shipper has a corresponding color, the
' arrays strArrShipperNames and intArrShipperColors
' always contain the same number of elements.
' Assign the color of the chart column, bar,
' slice etc.
chtObj.SeriesCollection(1).Points(i). _
Interior.Color = _
QBColor(intArrShipperColors(j))
End If
Next
rsRowSourceFiltered.MoveNext
Wend
End Sub