[AccessD] More MapPoint Help If Possible

To all,

I have the following code which sends a Client postcode and around 475 employee postcodes to MapPoint and returns the Mileage, however this takes around 16 minutes to complete which is far too long for our needs, can anyone see a way of speeding this up we really need this procedure to be as fast as possible.

Private Sub FlyMap_Click()
On Error Resume Next
    Dim rsClient As ADODB.Recordset
    Dim rsEmp As ADODB.Recordset
    Dim oMap As MapPoint.Map
    Dim oLoc1 As MapPoint.Location
    Dim oLoc2 As MapPoint.Location
    Dim strCPC As String
    
    Dim dtStart As Date
    Dim dtFinish As Date
    
    Set rsClient = New ADODB.Recordset
    rsClient.Open ("SELECT InvPostCode FROM tblClaires"), OpenDataConn, adOpenDynamic, adLockReadOnly
    strCPC = rsClient!InvPostCode
    rsClient.Close
    Set rsClient = Nothing
    
    Set rsEmp = New ADODB.Recordset
    rsEmp.Open ("SELECT PayrollNo, Postcode, DistFromClient FROM tblMidlands"), OpenDataConn, adOpenDynamic, adLockOptimistic
    
    Set oMap = CreateObject("MapPoint.Application").ActiveMap
    oMap.Parent.PaneState = geoPaneRoutePlanner
    
    With oMap.ActiveRoute
        rsEmp.MoveFirst
        dtStart = Format(Time(), "HH:MM:SS")
        
        Screen.MousePointer = vbHourglass
        
        Do Until (rsEmp.EOF)
            If (IsNull(rsEmp.Fields("Postcode")) = False Or rsEmp.Fields("Postcode") <> "") Then
                Set oLoc1 = oMap.FindResults(strCPC)(1)
                Set oLoc2 = oMap.FindResults(rsEmp.Fields("Postcode"))(1)
                If (oLoc1 Is Nothing Or oLoc2 Is Nothing) Then
                    ' **** No Results Returned ****
                Else
                    ' **** Results Returned So Calculate Distance Etc ****
                    .Waypoints.Add oLoc1, "Start"
                    .Waypoints.Add oLoc2, "End"
                    .Calculate
                    If (.IsCalculated = True) Then
                        rsEmp.Fields("DistFromClient") = Format(.Distance, "00.00")
                        rsEmp.Update
                    End If
                End If
            End If
            rsEmp.MoveNext
            .Clear
        Loop
        
        Screen.MousePointer = vbDefault
    End With
    rsEmp.Close
    Set rsEmp = Nothing
    oMap.Saved = True
    Set oMap = Nothing
    
    dtFinish = Format(Time(), "HH:MM:SS")
    MsgBox "Finished : " & Format(dtFinish - dtStart, "HH:MM:SS")
End Sub


Thanks in advance for any help and/or code samples

Paul Hartland

-- 

Whatever you Wanadoo:
http://www.wanadoo.co.uk/time/

This email has been checked for most known viruses - find out more at: http://www.wanadoo.co.uk/help/id/7098.htm