commoneventcode.bas

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

Attribute VB_Name = "CommonEventCode"
Option Explicit
'
' CommonEventCode supplies generic functions and procedures
' of use for linear referencing programs.
'

Private Function MinDouble(a As Double, b As Double) As Double
    '
    ' Returns the lesser value of {a,b}
    '
    If a < b Then
        MinDouble = a
    Else
        MinDouble = b
    End If
End Function

Public Function ReturnClosestLine(pt As MapObjects2.Point, ByRef lyr As MapObjects2.MapLayer, id_field As String, ByRef id As String, Optional ByRef envelope As MapObjects2.Rectangle = Nothing) As MapObjects2.Line
    '
    ' Search the given MapLayer and return the Line closest to the given Point.
    ' If id_field is specified, i.e. is not an empty string,  the id will be retrieved from the id_field.
    ' If a two dimensional envelope Rectangle is supplied, the search will take place within it.
    ' if the id_field Field can't be found, the MapLayer is empty, or is not of shape type moShapeTypeLine, returns an empty string.
    ' NB: Where features are coincident, this routine will return the first one it finds.
    '
    If lyr.Records.Count < 1 Or Not lyr.shapeType = moShapeTypeLine Then Exit Function
    If Not id_field = "" And lyr.Records.Fields.Item(id_field) Is Nothing Then Exit Function
    '
    ' Check that pt is inside the envelope, if one was supplied
    '
    If Not envelope Is Nothing Then
        If pt.X < envelope.Left Or pt.X > envelope.Right Or _
           pt.Y < envelope.Bottom Or pt.Y > envelope.Top Then
            Exit Function
        End If
    End If
    
    Dim result As MapObjects2.Line
    Dim search_distance As Double
    '
    ' Check whether pt coincides with any features
    '
    search_distance = 0
    Dim candidate_recs As MapObjects2.Recordset
    Set candidate_recs = lyr.SearchByDistance(pt, search_distance, "")
    
    If candidate_recs.Count = 0 Then
        '
        ' Calculate a suitable increment for search_distance.
        ' This will be 1 precent of the envelope, if supplied,
        ' or 0.5 percent of the full layer extent.
        '
        Dim increment As Double
        If Not envelope Is Nothing Then
            increment = envelope.Width / 100
        Else
            increment = lyr.Extent.Width / 200
        End If
        '
        ' Search by increasing distances from pt
        '
        Do
            search_distance = search_distance + increment
            If Not envelope Is Nothing Then
                '
                ' Check search is still within the envelope.
                ' NB - this is a rough approximation that effectively
                ' uses a circle based on the envelope's centre.
                '
                If (search_distance * 2) > MinDouble(envelope.Width, envelope.Height) Then Exit Function
            End If
            Set candidate_recs = lyr.SearchByDistance(pt, search_distance, "")
        Loop Until candidate_recs.Count > 0
    End If
    '
    ' Check for closest line in results
    '
    If candidate_recs.Count = 1 Then
        Set result = candidate_recs.Fields.Item("Shape").Value
        If Not id_field = "" Then id = candidate_recs.Fields.Item(id_field).ValueAsString
    Else
        Dim candidate_shape As MapObjects2.Line
        Dim closest_shape As MapObjects2.Line
        Set closest_shape = candidate_recs.Fields.Item("Shape").Value
        If Not id_field = "" Then id = candidate_recs.Fields.Item(id_field).ValueAsString
        
        candidate_recs.MoveNext
        While Not candidate_recs.EOF
            Set candidate_shape = candidate_recs.Fields.Item("Shape").Value
            If pt.DistanceTo(candidate_shape) < pt.DistanceTo(closest_shape) Then
                Set closest_shape = candidate_shape
                If Not id_field = "" Then id = candidate_recs.Fields.Item(id_field).ValueAsString
            End If
            candidate_recs.MoveNext
        Wend
        Set result = closest_shape
    End If
    
    Set ReturnClosestLine = result
End Function

Public Function ReturnClosestPointEvents(pt As MapObjects2.Point, ByRef lyr As MapObjects2.MapLayer, Optional ByRef envelope As MapObjects2.Rectangle = Nothing) As MapObjects2.Points
    '
    ' Returns the point events that occur on the feature that is nearest pt in lyr.
    ' If a two dimensional envelope Rectangle is supplied, the search will take place within it.
    ' Result will be Nothing if no event can be found.
    ' NB: Where features are coincident, this routine will use the one returned
    ' by ReturnClosestLine.  Other coincident features may have events closer
    ' to pt; these will not be returned.
    '
    ' Check whether events are being displayed
    '
    Dim evr As MapObjects2.EventRenderer
    Set evr = lyr.Renderer
    If evr Is Nothing Then Exit Function
    '
    ' Perform the search
    '
    Dim feature As MapObjects2.Line
    Dim feature_id As String
    Set feature = ReturnClosestLine(pt, lyr, evr.FeatureRouteIDField, feature_id, envelope)
    If feature Is Nothing Then Exit Function
    '
    ' Use the ID of the feature to carry out a search on your event table,
    ' getting back a Recordset of events that occur along that feature.
    ' NB: This approach assumes that features have unique route IDs.
    '
    Dim event_recs As MapObjects2.Recordset
    Set event_recs = evr.EventTable.SearchExpression(evr.EventRouteIDField & " = " & feature_id)
    If event_recs.CalculateStatistics(evr.EventRouteIDField).Count = 0 Then
        Exit Function
    End If
    '
    ' Use the point as an argument to the ReturnMeasure method of the line feature.
    ' This returns the measure value of the position on the line that occurs
    ' closest to the given point.
    '
    Dim query_measure As Double
    query_measure = Round(feature.ReturnMeasure(pt), 0)
    '
    ' Step through the Recordset of events and choose the event
    ' with the closest measure value.
    '
    Dim start_measure, next_measure As Double
    With event_recs
        start_measure = .Fields(evr.StartMeasureField).Value
        
        .MoveNext
        While Not event_recs.EOF
            next_measure = .Fields(evr.StartMeasureField).Value
            If Abs(query_measure - next_measure) < Abs(query_measure - start_measure) Then
                start_measure = next_measure
            End If
            event_recs.MoveNext
        Wend
    End With
    '
    ' Use start_measure to generate an event
    '
    Set ReturnClosestPointEvents = feature.ReturnPointEvents(start_measure)
End Function

Public Function ReturnClosestLinearEvent(pt As MapObjects2.Point, ByRef lyr As MapObjects2.MapLayer, Optional ByRef envelope As MapObjects2.Rectangle = Nothing) As MapObjects2.Line
    '
    ' Returns the linear event that occurs along the feature that is nearest pt in lyr.
    ' If a two dimensional envelope Rectangle is supplied, the search will take place within it.
    ' Result will be Nothing if no event can be found.
    ' NB: Where features are coincident, this routine will use the one returned
    ' by ReturnClosestLine.  Other coincident features may have events closer
    ' to pt; these will not be returned.
    '
    ' Check whether events are being displayed
    '
    Dim evr As MapObjects2.EventRenderer
    Set evr = lyr.Renderer
    If evr Is Nothing Then Exit Function
    '
    ' Check the EventRenderer is set up for linear events
    '
    If evr.EndMeasureField = "" Then Exit Function
    '
    ' Perform the search
    '
    Dim feature As MapObjects2.Line
    Dim feature_id As String
    Set feature = ReturnClosestLine(pt, lyr, evr.FeatureRouteIDField, feature_id, envelope)
    If feature Is Nothing Then Exit Function
    '
    ' Use the ID of the feature to carry out a search on your event table,
    ' getting back a Recordset of events that occur along that feature.
    ' NB: This approach assumes that features have unique route IDs.
    '
    Dim event_recs As MapObjects2.Recordset
    Set event_recs = evr.EventTable.SearchExpression(evr.EventRouteIDField & " = " & feature_id)
    If event_recs.CalculateStatistics(evr.EventRouteIDField).Count = 0 Then
        Exit Function
    End If
    '
    ' Use the point as an argument to the ReturnMeasure method of the line feature.
    ' This returns the measure value of the position on the line that occurs
    ' closest to the given point.
    '
    Dim query_measure As Double
    query_measure = Round(feature.ReturnMeasure(pt), 0)
    '
    ' Step through the Recordset of events and choose the event
    ' with the closest measure value.
    '
    Dim start_measure, end_measure As Double
    Dim next_start_measure, next_end_measure As Double
    Dim deltaM, next_deltaM As Double
    With event_recs
        start_measure = .Fields(evr.StartMeasureField).Value
        end_measure = .Fields(evr.EndMeasureField).Value
        deltaM = MinDouble(Abs(query_measure - start_measure), Abs(query_measure - end_measure))
        
        .MoveNext
        Do While Not event_recs.EOF
            next_start_measure = .Fields(evr.StartMeasureField).Value
            next_end_measure = .Fields(evr.EndMeasureField).Value
            next_deltaM = MinDouble(Abs(query_measure - next_start_measure), Abs(query_measure - next_end_measure))
            If ((next_start_measure <= query_measure) And (query_measure <= next_end_measure)) Then
                start_measure = next_start_measure
                end_measure = next_end_measure
                Exit Do
            ElseIf next_deltaM < deltaM Then
                deltaM = next_deltaM
                start_measure = next_start_measure
                end_measure = next_end_measure
            End If
            .MoveNext
        Loop
    End With
    '
    ' Use start_measure and end_measure to generate an event
    '
    Set ReturnClosestLinearEvent = feature.ReturnLineEvent(start_measure, end_measure)
End Function