ArcGIS网络分析最短路径分析源代码（VB6.0）

ArcGIS网络分析最短路径分析源代码（VB6.0）2009-10-06 cnblog 3echo
1
2" Copyright 1995-2005 ESRI
3
4" All rights reserved under the copyright laws of the United States.
5
6" You may freely redistribute and use this sample code, with or without modification.
7
8" Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
9" WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
10" FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR
11" CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
12" OR CONSEQUENTIAL DAMAGES （INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
13" SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
14" INTERRUPTION） SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY
15" THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY
16" WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF
17" SUCH DAMAGE.
18
19" For additional information contact: Environmental Systems Research Institute, Inc.
20
21" Attn: Contracts Dept.
22
23" 380 New York Street
24
25" Redlands, California, U.S.A. 92373
26
27" Email: contracts@esri.com
28
29Option Explicit
30
31" vb version of the PathFinder object
32
33" 本地变量
34Private m_ipGeometricNetwork As esriGeoDatabase.IGeometricNetwork
35Private m_ipMap As esriCarto.IMap
36Private m_ipPoints As esriGeometry.IPointCollection
37Private m_ipPointToEID As esriNetworkAnalysis.IPointToEID
38" 返回结果变量 
39Private m_dblPathCost As Double
40Private m_ipEnumNetEID_Junctions As esriGeoDatabase.IEnumNetEID
41Private m_ipEnumNetEID_Edges As esriGeoDatabase.IEnumNetEID
42Private m_ipPolyline As esriGeometry.IPolyline
43
44
45" Optionally set the Map （e.g. the current map in ArcMap）,
46" otherwise a default map will be made （for IPointToEID）.
47
48Public Property Set Map（Map As esriCarto.IMap）
49  Set m_ipMap = Map
50End Property
51
52Public Property Get Map（） As esriCarto.IMap
53  Set Map = m_ipMap
54End Property
55
56" Either OpenAccessNetwork or OpenFeatureDatasetNetwork
57" needs to be called.
58
59Public Sub OpenAccessNetwork（AccessFileName As String, FeatureDatasetName As String）
60  
61  Dim ipWorkspaceFactory As esriGeoDatabase.IWorkspaceFactory
62  Dim ipWorkspace As esriGeoDatabase.IWorkspace
63  Dim ipFeatureWorkspace As esriGeoDatabase.IFeatureWorkspace
64  Dim ipFeatureDataset As esriGeoDatabase.IFeatureDataset
65
66  " After this Sub exits, we"ll have an INetwork interface
67  " and an IMap interface initialized for the network we"ll be using.
68
69  " close down the last one if opened
70  CloseWorkspace
71
72  " open the mdb
73  Set ipWorkspaceFactory = New esriDataSourcesGDB.AccessWorkspaceFactory
74  Set ipWorkspace = ipWorkspaceFactory.OpenFromFile（AccessFileName, 0）
75
76  " get the FeatureWorkspace
77  Set ipFeatureWorkspace = ipWorkspace
78  
79  " open the FeatureDataset
80  Set ipFeatureDataset = ipFeatureWorkspace.OpenFeatureDataset（FeatureDatasetName）
81
82  " initialize Network and Map （m_ipNetwork, m_ipMap）
83  If Not InitializeNetworkAndMap（ipFeatureDataset） Then Err.Raise 0, "OpenAccessNetwork", "Error initializing Network and Map"
84
85End Sub
86
87Public Sub OpenFeatureDatasetNetwork（FeatureDataset As esriGeoDatabase.IFeatureDataset）
88  " close down the last one if opened
89  CloseWorkspace
90   
91  " we assume that the caller has passed a valid FeatureDataset
92
93  " initialize Network and Map （m_ipNetwork, m_ipMap）
94  If Not InitializeNetworkAndMap（FeatureDataset） Then Err.Raise 0, "OpenFeatureDatasetNetwork", "Error initializing Network and Map"
95
96End Sub
97
98" The collection of points to travel through must be set.
99
100Public Property Set StopPoints（Points As esriGeometry.IPointCollection）
101  Set m_ipPoints = Points
102End Property
103
104Public Property Get StopPoints（） As esriGeometry.IPointCollection
105  Set StopPoints = m_ipPoints
106End Property
107
108" Calculate the path
109
110Public Sub SolvePath（WeightName As String）
111  
112  Dim ipNetwork As esriGeoDatabase.INetwork
113  Dim ipTraceFlowSolver As esriNetworkAnalysis.ITraceFlowSolver
114  Dim ipNetSolver As esriNetworkAnalysis.INetSolver
115  Dim ipNetFlag As esriNetworkAnalysis.INetFlag
116  Dim ipaNetFlag（） As esriNetworkAnalysis.IEdgeFlag
117  Dim ipEdgePoint As esriGeometry.IPoint
118  Dim ipNetElements As esriGeoDatabase.INetElements
119  Dim intEdgeUserClassID As Long
120  Dim intEdgeUserID As Long
121  Dim intEdgeUserSubID As Long
122  Dim intEdgeID As Long
123  Dim ipFoundEdgePoint As esriGeometry.IPoint
124  Dim dblEdgePercent As Double
125  Dim ipNetWeight As esriGeoDatabase.INetWeight
126  Dim ipNetSolverWeights As esriNetworkAnalysis.INetSolverWeights
127  Dim ipNetSchema As esriGeoDatabase.INetSchema
128  Dim intCount As Long
129  Dim i As Long
130  Dim vaRes（） As Variant
131
132  " make sure we are ready
133  Debug.Assert Not m_ipPoints Is Nothing
134  Debug.Assert Not m_ipGeometricNetwork Is Nothing
135
136  " instantiate a trace flow solver
137  Set ipTraceFlowSolver = New esriNetworkAnalysis.TraceFlowSolver
138
139  " get the INetSolver interface
140  Set ipNetSolver = ipTraceFlowSolver
141
142  " set the source network to solve on
143  Set ipNetwork = m_ipGeometricNetwork.Network
144  Set ipNetSolver.SourceNetwork = ipNetwork
145
146  " make edge flags from the points
147
148  " the INetElements interface is needed to get UserID, UserClassID,
149  " and UserSubID from an element id
150  Set ipNetElements = ipNetwork
151
152  " get the count
153  intCount = m_ipPoints.PointCount
154  Debug.Assert intCount > 1
155
156  " dimension our IEdgeFlag array
157  ReDim ipaNetFlag（intCount）
158  
159  For i = 0 To intCount - 1
160    " make a new Edge Flag
161    Set ipNetFlag = New esriNetworkAnalysis.EdgeFlag
162    Set ipEdgePoint = m_ipPoints.Point（i）
163    " look up the EID for the current point  （this will populate intEdgeID and dblEdgePercent）
164    m_ipPointToEID.GetNearestEdge ipEdgePoint, intEdgeID, ipFoundEdgePoint, dblEdgePercent
165    Debug.Assert intEdgeID > 0   " else Point （eid） not found
166    ipNetElements.QueryIDs intEdgeID, esriETEdge, intEdgeUserClassID, intEdgeUserID, intEdgeUserSubID
167    Debug.Assert （intEdgeUserClassID > 0） And （intEdgeUserID > 0）  " else Point not found
168    ipNetFlag.UserClassID = intEdgeUserClassID
169    ipNetFlag.UserID = intEdgeUserID
170    ipNetFlag.UserSubID = intEdgeUserSubID
171    Set ipaNetFlag（i） = ipNetFlag
172  Next
173
174  " add these edge flags
175  ipTraceFlowSolver.PutEdgeOrigins intCount, ipaNetFlag（0）
176
177  " set the weight （cost field） to solve on
178
179  " get the INetSchema interface
180  Set ipNetSchema = ipNetwork
181  Set ipNetWeight = ipNetSchema.WeightByName（WeightName）
182  Debug.Assert Not ipNetWeight Is Nothing
183
184  " set the weight （use the same for both directions）
185  Set ipNetSolverWeights = ipTraceFlowSolver
186  Set ipNetSolverWeights.FromToEdgeWeight = ipNetWeight
187  Set ipNetSolverWeights.ToFromEdgeWeight = ipNetWeight
188
189  " initialize array for results to number of segments in result
190  ReDim vaRes（intCount - 1）
191
192  " solve it
193  ipTraceFlowSolver.FindPath esriFMConnected, esriSPObjFnMinSum, m_ipEnumNetEID_Junctions, m_ipEnumNetEID_Edges, intCount - 1, vaRes（0）
194
195  " compute total cost
196  m_dblPathCost = 0
197  For i = LBound（vaRes） To UBound（vaRes）
198    m_dblPathCost = m_dblPathCost + vaRes（i）
199  Next
200
201  " clear the last polyline result
202  Set m_ipPolyline = Nothing
203  
204End Sub
205
206" Property to get the cost
207
208Public Property Get PathCost（） As Double
209  PathCost = m_dblPathCost
210End Property
211
212" Property to get the shape
213
214Public Property Get PathPolyLine（） As esriGeometry.IPolyline
215
216  Dim ipEIDHelper As esriNetworkAnalysis.IEIDHelper
217  Dim count As Long, i As Long
218  Dim ipEIDInfo As esriNetworkAnalysis.IEIDInfo
219  Dim ipEnumEIDInfo As esriNetworkAnalysis.IEnumEIDInfo
220  Dim ipGeometry As esriGeometry.IGeometry
221  Dim ipNewGeometryColl As esriGeometry.IGeometryCollection
222  Dim ipSpatialReference As esriGeometry.ISpatialReference
223
224  " if the line is already computed since the last path, just return it
225  If Not m_ipPolyline Is Nothing Then
226    Set PathPolyLine = m_ipPolyline
227    Exit Property
228  End If
229
230  Set m_ipPolyline = New esriGeometry.Polyline
231  Set ipNewGeometryColl = m_ipPolyline
232
233  " a path should be solved first
234  Debug.Assert Not m_ipEnumNetEID_Edges Is Nothing
235
236  " make an EIDHelper object to translate edges to geometric features
237  Set ipEIDHelper = New esriNetworkAnalysis.EIDHelper
238  Set ipEIDHelper.GeometricNetwork = m_ipGeometricNetwork
239  Set ipSpatialReference = m_ipMap.SpatialReference
240  Set ipEIDHelper.OutputSpatialReference = ipSpatialReference
241  ipEIDHelper.ReturnGeometries = True
242
243  " get the details using the  IEIDHelper classes
244  Set ipEnumEIDInfo = ipEIDHelper.CreateEnumEIDInfo（m_ipEnumNetEID_Edges）
245  count = ipEnumEIDInfo.count
246
247  " set the iterator to beginning
248  ipEnumEIDInfo.Reset
249
250  For i = 1 To count
251      
252    " get the next EID and a copy of its geometry （it makes a Clone）
253    Set ipEIDInfo = ipEnumEIDInfo.Next
254    Set ipGeometry = ipEIDInfo.Geometry
255
256    ipNewGeometryColl.AddGeometryCollection ipGeometry
257
258  Next  " EID
259
260  " return the merged geometry as a Polyline
261  Set PathPolyLine = m_ipPolyline
262  
263End Property
264
265" Private
266
267Private Sub CloseWorkspace（）
268  " make sure we let go of everything and start with new results
269  Set m_ipGeometricNetwork = Nothing
270  Set m_ipPoints = Nothing
271  Set m_ipPointToEID = Nothing
272  Set m_ipEnumNetEID_Junctions = Nothing
273  Set m_ipEnumNetEID_Edges = Nothing
274  Set m_ipPolyline = Nothing
275End Sub
276
277Private Function InitializeNetworkAndMap（FeatureDataset As esriGeoDatabase.IFeatureDataset） As Boolean
278
279  Dim ipNetworkCollection As esriGeoDatabase.INetworkCollection
280  Dim ipNetwork As esriGeoDatabase.INetwork
281  Dim count As Long, i As Long
282  Dim ipFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
283  Dim ipFeatureClass As esriGeoDatabase.IFeatureClass
284  Dim ipGeoDataset As esriGeoDatabase.IGeoDataset
285  Dim ipLayer As esriCarto.ILayer
286  Dim ipFeatureLayer As esriCarto.IFeatureLayer
287  Dim ipEnvelope  As esriGeometry.IEnvelope, ipMaxEnvelope As esriGeometry.IEnvelope
288  Dim dblSearchTol As Double
289  Dim dblWidth As Double, dblHeight As Double
290
291  On Error GoTo Trouble
292
293  " get the networks
294  Set ipNetworkCollection = FeatureDataset
295
296  " even though a FeatureDataset can have many networks, we"ll just
297  " assume the first one （otherwise you would pass the network name in, etc.）
298
299  " get the count of networks
300  count = ipNetworkCollection.GeometricNetworkCount
301
302  Debug.Assert count > 0  " then Exception.Create（"No networks found"）;
303
304  " get the first Geometric Newtork （0 - based）
305  Set m_ipGeometricNetwork = ipNetworkCollection.GeometricNetwork（0）
306
307  " get the Network
308  Set ipNetwork = m_ipGeometricNetwork.Network
309
310  " The EID Helper class that converts points to EIDs needs a
311  " IMap, so we"ll need one around with all our layers added.
312  " This Pathfinder object has an optional Map property than may be set
313  " before opening the Network.
314  If m_ipMap Is Nothing Then
315    Set m_ipMap = New esriCarto.Map
316
317    " Add each of the Feature Classes in this Geometric Network as a map Layer
318    Set ipFeatureClassContainer = m_ipGeometricNetwork
319    count = ipFeatureClassContainer.ClassCount
320    Debug.Assert count > 0   " then Exception.Create（"No （network） feature classes found"）;
321
322    For i = 0 To count - 1
323      " get the feature class
324      Set ipFeatureClass = ipFeatureClassContainer.Class（i）
325      " make a layer
326      Set ipFeatureLayer = New esriCarto.FeatureLayer
327      Set ipFeatureLayer.FeatureClass = ipFeatureClass
328      " add layer to the map
329      m_ipMap.AddLayer ipFeatureLayer
330    Next
331  End If     "  we needed to make a Map
332
333
334  " Calculate point snap tolerance as 1/100 of map width.
335  count = m_ipMap.LayerCount
336  Set ipMaxEnvelope = New esriGeometry.Envelope
337  For i = 0 To count - 1
338    Set ipLayer = m_ipMap.Layer（i）
339    Set ipFeatureLayer = ipLayer
340    " get its dimensions （for setting search tolerance）
341    Set ipGeoDataset = ipFeatureLayer
342    Set ipEnvelope = ipGeoDataset.Extent
343    " merge with max dimensions
344    ipMaxEnvelope.Union ipEnvelope
345  Next
346
347  " finally, we can set up the IPointToEID 
348  Set m_ipPointToEID = New esriNetworkAnalysis.PointToEID
349  Set m_ipPointToEID.SourceMap = m_ipMap
350  Set m_ipPointToEID.GeometricNetwork = m_ipGeometricNetwork
351
352  " set snap tolerance
353  dblWidth = ipMaxEnvelope.Width
354  dblHeight = ipMaxEnvelope.Height
355
356  If dblWidth > dblHeight Then
357    dblSearchTol = dblWidth / 100#
358  Else
359    dblSearchTol = dblHeight / 100#
360  End If
361
362  m_ipPointToEID.SnapTolerance = dblSearchTol
363
364  InitializeNetworkAndMap = True      " good to go
365  Exit Function
366
367Trouble:
368  InitializeNetworkAndMap = False     " we had an error
369End Function
370