Code very slow

[Phil Stanton]

I am labelling points on a scatter graph with boat names. There are 68
points on the graph and it takes over 90 seconds to run this routine.

The computer is a fast dual core machine

Any ideas why tis proceedure is so slow.
The recordsource for the graph is

SELECT QSpaceAllocation.XPos, QSpaceAllocation.YPos,
QSpaceAllocation.SpaceAndName, QSpaceAllocation.StdLabPosLeft,
QSpaceAllocation.StdXLabOffset, QSpaceAllocation.StdLabPosUp,
QSpaceAllocation.StdYLabOffset, QSpaceAllocation.StdLabOrientation,
QSpaceAllocation.XLabelPosition, QSpaceAllocation.YLabelPosition,
QSpaceAllocation.LabelAngle FROM QSpaceAllocation ORDER BY
QSpaceAllocation.XPos, QSpaceAllocation.YPos, QSpaceAllocation.SpaceAndName;


The XPos and YPos are the positions of the points: The SpaceAndName is the
label.Caption: Anything begining with Std is to do with positioning all the
labels on the graph relative to the XY position. Other fields are for
over-riding the standard position and orientation.

I have half written the code to "Jiggle" the labels but as this is running
so slowly, I am reluctant to proceed.

Thanks

Phil

' Label points with Standard offsets and angles
Function LabelIt() As Boolean

Dim Cht As Graph.Chart
Dim ChtSeries As Series
Dim ChtLabel As DataLabel
Dim ChtArea As ChartArea
Dim DataSht As DataSheet
Dim pntDataPoint As Point
Dim OrderPos As Integer
Dim lCount As Long
Dim DirectionUp As String
Dim IncrementUp As Long
Dim DirectionLeft As String
Dim IncrementLeft As Long
Dim Orientation As Integer
Dim LblYOffset As Long, LblXOffset As Long

Dim MyDb As Database
Dim SpaceAllocationSet As Recordset
Dim SQLStg As String, Stg As String
Dim NoPoints As Integer
Dim LngRtn As Long

Const szSOURCE As String = "LabelIt()"

Set MyDb = CurrentDb

AllocationPlan.Refresh
DoEvents

Set Cht = Me.AllocationPlan.Object
Set DataSht = Cht.Application.DataSheet
'ChartHeight = Cht.Height
'ChartWidth = Cht.Width

Stg = Me.AllocationPlan.RowSource
Stg = Left(Stg, Len(Stg) - 1) ' Remove last ;
OrderPos = InStr(Stg, "ORDER BY")
SQLStg = Left(Stg, OrderPos - 1) & "WHERE SpaceTypeID = " & SpaceTypeID
SQLStg = SQLStg & " " & Mid(Stg, OrderPos) & ";"

Set SpaceAllocationSet = MyDb.OpenRecordset(SQLStg)
Set ChtSeries = Cht.SeriesCollection(1)

Cht.HasDataTable = True

Cht.ApplyDataLabels Type:=xlDataLabelsShowValue, AutoText:=True,
LegendKey:=False


With SpaceAllocationSet
.MoveLast
NoPoints = .RecordCount
.MoveFirst
' Get info all the same of each SpaceTypeID
'LblAngle = !LabelAngle
DirectionUp = !StdLabPosUp
DirectionLeft = !StdLabPosLeft
LblXOffset = !StdXLabOffset
LblYOffset = !StdYLabOffset
Orientation = !StdLabOrientation

LngRtn = SysCmd(acSysCmdInitMeter, "Labeling " & NoPoints & "
points", NoPoints)
ChtSeries.MarkerStyle = xlMarkerStyleX
ChtSeries.MarkerSize = 4
ChtSeries.MarkerForegroundColorIndex = 3 ' Red
ChtSeries.MarkerBackgroundColorIndex = xlColorIndexNone
' Enable Data Labels in the chart

'Loop through each data label and set its
'Top, Left, and Font properties
For lCount = 1 To ChtSeries.Points.Count
Set pntDataPoint = ChtSeries.Points(lCount)
Err.Clear
If pntDataPoint.HasDataLabel = True Then
' Add the data label and position it if necessary.
Set ChtLabel = pntDataPoint.DataLabel
ChtLabel.Position = xlLabelPositionCenter

ChtLabel.Caption = !SpaceAndName

Select Case DirectionUp
Case "U" ' Up
ChtLabel.Top = ChtLabel.Top - IncrementUp
Case "D" ' Down
ChtLabel.Top = ChtLabel.Top + IncrementUp
Case Else
MsgBox "Unrecognised Vertical Direction", vbCritical
Exit Function
End Select
Select Case DirectionLeft
Case "L" ' Left
ChtLabel.Left = ChtLabel.Left - IncrementLeft
Case "R" ' Right
ChtLabel.Left = ChtLabel.Left + IncrementLeft
Case Else
MsgBox "Unrecognised Horizontal Direction",
vbCritical
Exit Function
End Select

' Set angle

ChtLabel.Orientation = Orientation

ChtLabel.Font.Color = RGB(0, 0, 0) ' Black
ChtLabel.Font.Size = 7
ChtLabel.Font.Name = "Arial"
ChtLabel.Font.Bold = False
.MoveNext
LngRtn = SysCmd(acSysCmdUpdateMeter, lCount)
End If
Next
.Close
Set SpaceAllocationSet = Nothing
End With

AllocationPlan_Exit:

LngRtn = SysCmd(acSysCmdRemoveMeter)
LabelIt = True
Exit Function

AllocationPlan_Err:

If Err.Number <> glHANDLED_ERROR Then Err.Description = Err.Description
& " (" & szSOURCE & ")"
If bCentralErrorHandler(False) Then
Stop
Resume Next
Else
Resume AllocationPlan_Exit
End If

End Function

 

[Tim Williams]

Have you tried turning off screenupdating while the plot is being updated ?

Tim

 

[Phil Stanton]

Have you tried turning off screenupdating while the plot is being updated
?

Tim

Hi Tim

Given it a go. No difference I'm afarid. Eitherway the chart does not change
until the Exit Function is reached. Surprised, as I thought I would see the
labels appearing

Thanks,

Phil