ArcGIS网络分析最短路径分析源代码(VB6.0)
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
29
Option Explicit
30
31
' vb version of the PathFinder object
32
33
' 本地变量
34
Private m_ipGeometricNetwork As esriGeoDatabase.IGeometricNetwork
35
Private m_ipMap As esriCarto.IMap
36
Private m_ipPoints As esriGeometry.IPointCollection
37
Private m_ipPointToEID As esriNetworkAnalysis.IPointToEID
38
' 返回结果变量
39
Private m_dblPathCost As Double
40
Private m_ipEnumNetEID_Junctions As esriGeoDatabase.IEnumNetEID
41
Private m_ipEnumNetEID_Edges As esriGeoDatabase.IEnumNetEID
42
Private 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
48
Public Property Set Map(Map As esriCarto.IMap)
49
Set m_ipMap = Map
50
End Property
51
52
Public Property Get Map() As esriCarto.IMap
53
Set Map = m_ipMap
54
End Property
55
56
' Either OpenAccessNetwork or OpenFeatureDatasetNetwork
57
' needs to be called.
58
59
Public 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
85
End Sub
86
87
Public 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
96
End Sub
97
98
' The collection of points to travel through must be set.
99
100
Public Property Set StopPoints(Points As esriGeometry.IPointCollection)
101
Set m_ipPoints = Points
102
End Property
103
104
Public Property Get StopPoints() As esriGeometry.IPointCollection
105
Set StopPoints = m_ipPoints
106
End Property
107
108
' Calculate the path
109
110
Public 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
204
End Sub
205
206
' Property to get the cost
207
208
Public Property Get PathCost() As Double
209
PathCost = m_dblPathCost
210
End Property
211
212
' Property to get the shape
213
214
Public 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
263
End Property
264
265
' Private
266
267
Private 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
275
End Sub
276
277
Private 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
367
Trouble:
368
InitializeNetworkAndMap = False ' we had an error
369
End Function
370

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

92

93

94

95

96

97

98

99

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347


348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370
