cpathfinder.cls

路径查找代码[vb版本代码]

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PathFinder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' vb version of the PathFinder object

' local vars
Private m_ipGeometricNetwork As esriCore.IGeometricNetwork
Private m_ipMap As esriCore.IMap
Private m_ipPoints As esriCore.IPointCollection
Private m_ipPointToEID As esriCore.IPointToEID
' reults
Private m_dblPathCost As Double
Private m_ipEnumNetEID_Junctions As esriCore.IEnumNetEID
Private m_ipEnumNetEID_Edges As esriCore.IEnumNetEID
Private m_ipPolyline As esriCore.IPolyline


' Optionally set the Map (e.g. the current map in ArcMap),
' otherwise a default map will be made (for IPointToEID).

Public Property Set Map(Map As esriCore.IMap)
  Set m_ipMap = Map
End Property

Public Property Get Map() As esriCore.IMap
  Set Map = m_ipMap
End Property

' Either OpenAccessNetwork or OpenFeatureDatasetNetwork
' needs to be called.

Public Sub OpenAccessNetwork(AccessFileName As String, FeatureDatasetName As String)
  
  Dim ipWorkspaceFactory As esriCore.IWorkspaceFactory
  Dim ipWorkspace As esriCore.IWorkspace
  Dim ipFeatureWorkspace As esriCore.IFeatureWorkspace
  Dim ipFeatureDataset As esriCore.IFeatureDataset

  ' After this Sub exits, we'll have an INetwork interface
  ' and an IMap interface initialized for the network we'll be using.

  ' close down the last one if opened
  CloseWorkspace

  ' open the mdb
  Set ipWorkspaceFactory = New esriCore.AccessWorkspaceFactory
  Set ipWorkspace = ipWorkspaceFactory.OpenFromFile(AccessFileName, 0)

  ' get the FeatureWorkspace
  Set ipFeatureWorkspace = ipWorkspace
  
  ' open the FeatureDataset
  Set ipFeatureDataset = ipFeatureWorkspace.OpenFeatureDataset(FeatureDatasetName)

  ' initialize Network and Map (m_ipNetwork, m_ipMap)
  If Not InitializeNetworkAndMap(ipFeatureDataset) Then Err.Raise 0, "OpenAccessNetwork", "Error initializing Network and Map"

End Sub

Public Sub OpenFeatureDatasetNetwork(FeatureDataset As esriCore.IFeatureDataset)
  ' close down the last one if opened
  CloseWorkspace
   
  ' we assume that the caller has passed a valid FeatureDataset

  ' initialize Network and Map (m_ipNetwork, m_ipMap)
  If Not InitializeNetworkAndMap(FeatureDataset) Then Err.Raise 0, "OpenFeatureDatasetNetwork", "Error initializing Network and Map"

End Sub

' The collection of points to travel through must be set.

Public Property Set StopPoints(Points As esriCore.IPointCollection)
  Set m_ipPoints = Points
End Property

Public Property Get StopPoints() As esriCore.IPointCollection
  Set StopPoints = m_ipPoints
End Property

' Calculate the path

Public Sub SolvePath(WeightName As String)
  
  Dim ipNetwork As esriCore.INetwork
  Dim ipTraceFlowSolver As esriCore.ITraceFlowSolver
  Dim ipNetSolver As esriCore.INetSolver
  Dim ipNetFlag As esriCore.INetFlag
  Dim ipaNetFlag() As esriCore.IEdgeFlag
  Dim ipEdgePoint As esriCore.IPoint
  Dim ipNetElements As esriCore.INetElements
  Dim intEdgeUserClassID As Long
  Dim intEdgeUserID As Long
  Dim intEdgeUserSubID As Long
  Dim intEdgeID As Long
  Dim ipFoundEdgePoint As esriCore.IPoint
  Dim dblEdgePercent As Double
  Dim ipNetWeight As esriCore.INetWeight
  Dim ipNetSolverWeights As esriCore.INetSolverWeights
  Dim ipNetSchema As esriCore.INetSchema
  Dim intCount As Long
  Dim i As Long
  Dim vaRes() As Variant

  ' make sure we are ready
  Debug.Assert Not m_ipPoints Is Nothing
  Debug.Assert Not m_ipGeometricNetwork Is Nothing

  ' instantiate a trace flow solver
  Set ipTraceFlowSolver = New esriCore.TraceFlowSolver

  ' get the INetSolver interface
  Set ipNetSolver = ipTraceFlowSolver

  ' set the source network to solve on
  Set ipNetwork = m_ipGeometricNetwork.Network
  Set ipNetSolver.SourceNetwork = ipNetwork

  ' make edge flags from the points

  ' the INetElements interface is needed to get UserID, UserClassID,
  ' and UserSubID from an element id
  Set ipNetElements = ipNetwork

  ' get the count
  intCount = m_ipPoints.PointCount
  Debug.Assert intCount > 1

  ' dimension our IEdgeFlag array
  ReDim ipaNetFlag(intCount)
  
  For i = 0 To intCount - 1
    ' make a new Edge Flag
    Set ipNetFlag = New esriCore.EdgeFlag
    Set ipEdgePoint = m_ipPoints.Point(i)
    ' look up the EID for the current point  (this will populate intEdgeID and dblEdgePercent)
    m_ipPointToEID.GetNearestEdge ipEdgePoint, intEdgeID, ipFoundEdgePoint, dblEdgePercent
    Debug.Assert intEdgeID > 0   ' else Point (eid) not found
    ipNetElements.QueryIDs intEdgeID, esriETEdge, intEdgeUserClassID, intEdgeUserID, intEdgeUserSubID
    Debug.Assert (intEdgeUserClassID > 0) And (intEdgeUserID > 0)  ' else Point not found
    ipNetFlag.UserClassID = intEdgeUserClassID
    ipNetFlag.UserID = intEdgeUserID
    ipNetFlag.UserSubID = intEdgeUserSubID
    Set ipaNetFlag(i) = ipNetFlag
  Next

  ' add these edge flags
  ipTraceFlowSolver.PutEdgeOrigins intCount, ipaNetFlag(0)

  ' set the weight (cost field) to solve on

  ' get the INetSchema interface
  Set ipNetSchema = ipNetwork
  Set ipNetWeight = ipNetSchema.WeightByName(WeightName)
  Debug.Assert Not ipNetWeight Is Nothing

  ' set the weight (use the same for both directions)
  Set ipNetSolverWeights = ipTraceFlowSolver
  Set ipNetSolverWeights.FromToEdgeWeight = ipNetWeight
  Set ipNetSolverWeights.ToFromEdgeWeight = ipNetWeight

  ' initialize array for results to number of segments in result
  ReDim vaRes(intCount - 1)

  ' solve it
  ipTraceFlowSolver.FindPath esriFMConnected, esriSPObjFnMinSum, m_ipEnumNetEID_Junctions, m_ipEnumNetEID_Edges, intCount - 1, vaRes(0)

  ' compute total cost
  m_dblPathCost = 0
  For i = LBound(vaRes) To UBound(vaRes)
    m_dblPathCost = m_dblPathCost + vaRes(i)
  Next

  ' clear the last polyline result
  Set m_ipPolyline = Nothing
  
End Sub

' Property to get the cost

Public Property Get PathCost() As Double
  PathCost = m_dblPathCost
End Property

' Property to get the shape

Public Property Get PathPolyLine() As esriCore.IPolyline

  Dim ipEIDHelper As esriCore.IEIDHelper
  Dim count As Long, i As Long
  Dim ipEIDInfo As esriCore.IEIDInfo
  Dim ipEnumEIDInfo As esriCore.IEnumEIDInfo
  Dim ipGeometry As esriCore.IGeometry
  Dim ipNewGeometryColl As esriCore.IGeometryCollection
  Dim ipSpatialReference As esriCore.ISpatialReference

  ' if the line is already computed since the last path, just return it
  If Not m_ipPolyline Is Nothing Then
    Set PathPolyLine = m_ipPolyline
    Exit Property
  End If

  Set m_ipPolyline = New esriCore.Polyline
  Set ipNewGeometryColl = m_ipPolyline

  ' a path should be solved first
  Debug.Assert Not m_ipEnumNetEID_Edges Is Nothing

  ' make an EIDHelper object to translate edges to geometric features
  Set ipEIDHelper = New esriCore.EIDHelper
  Set ipEIDHelper.GeometricNetwork = m_ipGeometricNetwork
  Set ipSpatialReference = m_ipMap.SpatialReference
  Set ipEIDHelper.OutputSpatialReference = ipSpatialReference
  ipEIDHelper.ReturnGeometries = True

  ' get the details using the  IEIDHelper classes
  Set ipEnumEIDInfo = ipEIDHelper.CreateEnumEIDInfo(m_ipEnumNetEID_Edges)
  count = ipEnumEIDInfo.count

  ' set the iterator to beginning
  ipEnumEIDInfo.Reset

  For i = 1 To count
      
    ' get the next EID and a copy of its geometry (it makes a Clone)
    Set ipEIDInfo = ipEnumEIDInfo.Next
    Set ipGeometry = ipEIDInfo.Geometry

    ipNewGeometryColl.AddGeometryCollection ipGeometry

  Next  ' EID

  ' return the merged geometry as a Polyline
  Set PathPolyLine = m_ipPolyline
  
End Property

' Private

Private Sub CloseWorkspace()
  ' make sure we let go of everything and start with new results
  Set m_ipGeometricNetwork = Nothing
  Set m_ipPoints = Nothing
  Set m_ipPointToEID = Nothing
  Set m_ipEnumNetEID_Junctions = Nothing
  Set m_ipEnumNetEID_Edges = Nothing
  Set m_ipPolyline = Nothing
End Sub

Private Function InitializeNetworkAndMap(FeatureDataset As esriCore.IFeatureDataset) As Boolean

  Dim ipNetworkCollection As esriCore.INetworkCollection
  Dim ipNetwork As esriCore.INetwork
  Dim count As Long, i As Long
  Dim ipFeatureClassContainer As esriCore.IFeatureClassContainer
  Dim ipFeatureClass As esriCore.IFeatureClass
  Dim ipGeoDataset As esriCore.IGeoDataset
  Dim ipLayer As esriCore.ILayer
  Dim ipFeatureLayer As esriCore.IFeatureLayer
  Dim ipEnvelope  As esriCore.IEnvelope, ipMaxEnvelope As esriCore.IEnvelope
  Dim dblSearchTol As Double
  Dim dblWidth As Double, dblHeight As Double

  On Error GoTo Trouble

  ' get the networks
  Set ipNetworkCollection = FeatureDataset

  ' even though a FeatureDataset can have many networks, we'll just
  ' assume the first one (otherwise you would pass the network name in, etc.)

  ' get the count of networks
  count = ipNetworkCollection.GeometricNetworkCount

  Debug.Assert count > 0  ' then Exception.Create('No networks found');

  ' get the first Geometric Newtork (0 - based)
  Set m_ipGeometricNetwork = ipNetworkCollection.GeometricNetwork(0)

  ' get the Network
  Set ipNetwork = m_ipGeometricNetwork.Network

  ' The EID Helper class that converts points to EIDs needs a
  ' IMap, so we'll need one around with all our layers added.
  ' This Pathfinder object has an optional Map property than may be set
  ' before opening the Network.
  If m_ipMap Is Nothing Then
    Set m_ipMap = New esriCore.Map

    ' Add each of the Feature Classes in this Geometric Network as a map Layer
    Set ipFeatureClassContainer = m_ipGeometricNetwork
    count = ipFeatureClassContainer.ClassCount
    Debug.Assert count > 0   ' then Exception.Create('No (network) feature classes found');

    For i = 0 To count - 1
      ' get the feature class
      Set ipFeatureClass = ipFeatureClassContainer.Class(i)
      ' make a layer
      Set ipFeatureLayer = New esriCore.FeatureLayer
      Set ipFeatureLayer.FeatureClass = ipFeatureClass
      ' add layer to the map
      m_ipMap.AddLayer ipFeatureLayer
    Next
  End If     '  we needed to make a Map


  ' Calculate point snap tolerance as 1/100 of map width.
  count = m_ipMap.LayerCount
  Set ipMaxEnvelope = New esriCore.Envelope
  For i = 0 To count - 1
    Set ipLayer = m_ipMap.Layer(i)
    Set ipFeatureLayer = ipLayer
    ' get its dimensions (for setting search tolerance)
    Set ipGeoDataset = ipFeatureLayer
    Set ipEnvelope = ipGeoDataset.Extent
    ' merge with max dimensions
    ipMaxEnvelope.Union ipEnvelope
  Next

  ' finally, we can set up the IPointToEID ...
  Set m_ipPointToEID = New esriCore.PointToEID
  Set m_ipPointToEID.SourceMap = m_ipMap
  Set m_ipPointToEID.GeometricNetwork = m_ipGeometricNetwork

  ' set snap tolerance
  dblWidth = ipMaxEnvelope.Width
  dblHeight = ipMaxEnvelope.Height

  If dblWidth > dblHeight Then
    dblSearchTol = dblWidth / 100#
  Else
    dblSearchTol = dblHeight / 100#
  End If

  m_ipPointToEID.SnapTolerance = dblSearchTol

  InitializeNetworkAndMap = True      ' good to go
  Exit Function

Trouble:
  InitializeNetworkAndMap = False     ' we had an error
End Function