form1.frm

有关ＶＢ在GIS空间分析方面的应用 深入详解代码大家在这方面多交流啊

VERSION 5.00
Object = "{C552EA90-6FBB-11D5-A9C1-00104BB6FC1C}#1.0#0"; "MapControl.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   7065
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   9990
   LinkTopic       =   "Form1"
   ScaleHeight     =   7065
   ScaleWidth      =   9990
   StartUpPosition =   3  'Windows Default
   Begin esriMapControl.MapControl MapControl1 
      Height          =   6855
      Left            =   120
      OleObjectBlob   =   "Form1.frx":0000
      TabIndex        =   0
      Top             =   120
      Width           =   9735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' 定义几何网络
Public m_ipGeometricNetwork As IGeometricNetwork
' 用来存储鼠标确定的目标点
Public m_ipPoints As IPointCollection
Public m_ipPointToEID As IPointToEID
Public m_ipEnumNetEID_Junctions As IEnumNetEID
Public m_ipEnumNetEID_Edges As IEnumNetEID
Public m_ipPolyline As IPolyline


Private Sub Form_Load()
  Dim str As String
'此处修改存储几何网络的Personal Geodatabase的名称和路径
'str = "F:\Personal Geodatabase.mdb"
str = "E:\Teaching\GIS_Practise\2006\Practise_Data\NetworkAnalysis.mdb"
Dim m_pWSF As IWorkspaceFactory
Dim pDS As IDataset
       Dim m_pEnumData As IEnumDataset
       Dim m_pDS As IDataset
       Dim pEnumFC As IEnumFeatureClass
        Set m_pWSF = New AccessWorkspaceFactory
        Dim m_pWS As IWorkspace
        Dim m_pFWS As IFeatureWorkspace
        Set m_pFWS = m_pWSF.OpenFromFile(str, 0)
Dim m_pFDS As IFeatureDataset
'此处修改存储几何网络的FeatureDataset的名称
Set m_pFDS = m_pFWS.OpenFeatureDataset("high")
'Set m_pWS = m_pFDS.Workspace
Set m_pEnumData = m_pFDS.Subsets
m_pEnumData.Reset
Set m_pDS = m_pEnumData.Next
'此处修改几何网络的名称
Do While m_pDS.Name <> "high_Net"
   Set m_pDS = m_pEnumData.Next
Loop
  Set m_ipGeometricNetwork = m_pDS
  Set pEnumFC = GetEnumNetFC(esriFTSimpleEdge)
  AddMapLayers pEnumFC
  Set pEnumFC = GetEnumNetFC(esriFTComplexEdge)
  AddMapLayers pEnumFC
  Set pEnumFC = GetEnumNetFC(esriFTSimpleJunction)
  AddMapLayers pEnumFC
  Set pEnumFC = Nothing
End Sub

Public Function GetEnumNetFC(ftype As esriFeatureType) As IEnumFeatureClass
  Dim pEnumFC As IEnumFeatureClass
  
  On Error GoTo Fail
  Set GetEnumNetFC = Nothing
  If m_ipGeometricNetwork Is Nothing Then Exit Function
  Set pEnumFC = Nothing
  Set pEnumFC = m_ipGeometricNetwork.ClassesByType(ftype)
  If pEnumFC Is Nothing Then Exit Function
  pEnumFC.Reset
  Set GetEnumNetFC = pEnumFC
  Exit Function

Fail:
  Set GetEnumNetFC = Nothing
End Function

Private Sub AddMapLayer(pFC As IFeatureClass)
  Dim pDS As IDataset
  Dim pgflyr As IGeoFeatureLayer
  Dim feattype As esriFeatureType
  Dim pSRen As ISimpleRenderer
  Dim pURen As IUniqueValueRenderer
  Dim blnUVR As Boolean
  Dim pMarkerSym As ISimpleMarkerSymbol
  Dim pLineSym As ISimpleLineSymbol
  Dim pRed As IRgbColor
  Dim pBlue As IRgbColor
  Set pRed = New RgbColor
  Set pBlue = New RgbColor
  pRed.Red = 255
  pRed.Blue = 0
  pRed.Green = 0
  pBlue.Red = 0
  pBlue.Green = 0
  pBlue.Blue = 255
On Error GoTo Fail
  If pFC Is Nothing Then Exit Sub
  feattype = pFC.FeatureType
  Set pgflyr = New FeatureLayer
  Set pgflyr.FeatureClass = pFC
  Set pDS = pFC
  pgflyr.Name = pDS.Name
 If TypeOf pgflyr.Renderer Is IUniqueValueRenderer Then
     Set pURen = pgflyr.Renderer
     blnUVR = True
  Else
    Set pSRen = pgflyr.Renderer
    blnUVR = False
  End If
Select Case pFC.FeatureType
  Case esriFTSimpleEdge, esriFTComplexEdge
    Set pLineSym = New SimpleLineSymbol
    pLineSym.Color = pBlue
    pLineSym.Width = 1
  If blnUVR Then
      pURen.DefaultSymbol = pLineSym
  Else
     Set pSRen.Symbol = pLineSym
  End If
  Case esriFTSimpleJunction
    Set pMarkerSym = New SimpleMarkerSymbol
    pMarkerSym.Color = pRed
    pMarkerSym.Size = 3
  If blnUVR Then
      pURen.DefaultSymbol = pMarkerSym
  Else
      Set pSRen.Symbol = pMarkerSym
  End If
Case Else
  End Select
  MapControl1.AddLayer pgflyr
  Exit Sub
Fail:
  Debug.Assert False
End Sub
Private Sub AddMapLayers(pEnumFC As IEnumFeatureClass)
  Dim pFC As IFeatureClass
  
  If pEnumFC Is Nothing Then Exit Sub
  Set pFC = pEnumFC.Next
  Do While Not pFC Is Nothing
    AddMapLayer pFC
    Set pFC = pEnumFC.Next
  Loop
End Sub

Public Sub SolvePath(WeightName As String)
  Dim ipNetwork As INetwork
  Dim ipTraceFlowSolver As ITraceFlowSolver
  Dim ipNetSolver As INetSolver
  Dim ipNetFlag As INetFlag
  Dim ipaNetFlag() As IJunctionFlag
  Dim ipEdgePoint As IPoint
  Dim ipNetElements As INetElements
  Dim intEdgeUserClassID As Long
  Dim intEdgeUserID As Long
  Dim intEdgeUserSubID As Long
  Dim intEdgeID As Long
  Dim ipFoundEdgePoint As IPoint
  Dim dblEdgePercent As Double
  Dim ipNetWeight As INetWeight
  Dim ipNetSolverWeights As INetSolverWeights
  Dim ipNetSchema As INetSchema
  Dim intCount As Long
  Dim i As Long
  Dim vaRes() As Variant
  ' 检查数据
 Debug.Assert Not m_ipPoints Is Nothing
  Debug.Assert Not m_ipGeometricNetwork Is Nothing
  Set ipTraceFlowSolver = New TraceFlowSolver
  Set m_ipPointToEID = New PointToEID
  Set m_ipPointToEID.GeometricNetwork = m_ipGeometricNetwork
  Set m_ipPointToEID.SourceMap = MapControl1.Map
  Dim dblWidth As Double
  Dim dblHeight As Double
  Dim dblSearchTol As Double
  dblWidth = MapControl1.Width
  dblHeight = MapControl1.Height
  If dblWidth > dblHeight Then
    dblSearchTol = dblWidth / 100#
  Else
    dblSearchTol = dblHeight / 100#
  End If
m_ipPointToEID.SnapTolerance = dblSearchTol
Set ipNetSolver = ipTraceFlowSolver
  ' 设置分析执行的几何网络
  Set ipNetwork = m_ipGeometricNetwork.Network
  Set ipNetSolver.SourceNetwork = ipNetwork
  Set ipNetElements = ipNetwork
  
' 得到分析需要经过的接点数
  intCount = m_ipPoints.PointCount
  ReDim ipaNetFlag(intCount)
 For i = 0 To intCount - 1
    Set ipNetFlag = New JunctionFlag
    Set ipEdgePoint = m_ipPoints.Point(i)
   m_ipPointToEID.GetNearestJunction ipEdgePoint, intEdgeID, ipFoundEdgePoint
    Dim x As Long
    x = ipEdgePoint.x
    Debug.Assert intEdgeID > 0
    ipNetElements.QueryIDs intEdgeID, esriETJunction, intEdgeUserClassID, intEdgeUserID, intEdgeUserSubID
    
    Debug.Assert (intEdgeUserClassID > 0) And (intEdgeUserID > 0)
    ipNetFlag.UserClassID = intEdgeUserClassID
    ipNetFlag.UserID = intEdgeUserID
    ipNetFlag.UserSubID = intEdgeUserSubID
    Set ipaNetFlag(i) = ipNetFlag
  Next
ipTraceFlowSolver.PutJunctionOrigins intCount, ipaNetFlag(0)
  Set ipNetSchema = ipNetwork
  Set ipNetWeight = ipNetSchema.WeightByName(WeightName)
  Debug.Assert Not ipNetWeight Is Nothing
  Set ipNetSolverWeights = ipTraceFlowSolver
  Set ipNetSolverWeights.FromToEdgeWeight = ipNetWeight
  Set ipNetSolverWeights.ToFromEdgeWeight = ipNetWeight
  ReDim vaRes(intCount - 1)
  ipTraceFlowSolver.FindPath esriFMConnected, esriSPObjFnMinSum, m_ipEnumNetEID_Junctions, m_ipEnumNetEID_Edges, intCount - 1, vaRes(0)
  Set m_ipPolyline = Nothing
End Sub


Private Sub MapControl1_OnDoubleClick(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)
     Dim ipPolyResult As IPolyline
  Dim ipGraphicsContainer As IGraphicsContainer
  Dim ipElemet As IElement
  Dim pScreenDisplay As IScreenDisplay
  Dim ipLineSymbol As ILineSymbol
  Dim m_ipClipEnv As IEnvelope
  Dim pView As IActiveView
  Set pView = MapControl1.Map
  
  On Error GoTo CleanUp
 '  Debug.Assert m_ipPoints.PointCount > 1
'此处修改为自己的几何网络的权重
SolvePath "Length"
Set ipPolyResult = PathPolyLine
Set pScreenDisplay = pView.ScreenDisplay
Set ipLineSymbol = New CartographicLineSymbol
  ipLineSymbol.Width = 5
pScreenDisplay.StartDrawing 0, esriNoScreenCache
  
  pScreenDisplay.SetSymbol ipLineSymbol
  pScreenDisplay.DrawPolyline ipPolyResult
  Set m_ipClipEnv = pScreenDisplay.ClipEnvelope
  pScreenDisplay.FinishDrawing
  
CleanUp:
  
  Set m_ipPoints = Nothing ' clear it

End Sub
Public Function PathPolyLine() As IPolyline
  Dim ipEIDHelper As IEIDHelper
  Dim count As Long, i As Long
  Dim ipEIDInfo As IEIDInfo
  Dim ipEnumEIDInfo As IEnumEIDInfo
  Dim ipGeometry As IGeometry
  Dim ipNewGeometryColl As IGeometryCollection
  Dim ipSpatialReference As ISpatialReference
  If Not m_ipPolyline Is Nothing Then
    Set PathPolyLine = m_ipPolyline
    Exit Function
  End If
  Set m_ipPolyline = New Polyline
  Set ipNewGeometryColl = m_ipPolyline
  Debug.Assert Not m_ipEnumNetEID_Edges Is Nothing
  Set ipEIDHelper = New EIDHelper
  Set ipEIDHelper.GeometricNetwork = m_ipGeometricNetwork
  Set ipSpatialReference = MapControl1.Map.SpatialReference
  Set ipEIDHelper.OutputSpatialReference = ipSpatialReference
  ipEIDHelper.ReturnGeometries = True

 Set ipEnumEIDInfo = ipEIDHelper.CreateEnumEIDInfo(m_ipEnumNetEID_Edges)
  count = ipEnumEIDInfo.count
  ipEnumEIDInfo.Reset
 For i = 1 To count
    Set ipEIDInfo = ipEnumEIDInfo.Next
    Set ipGeometry = ipEIDInfo.Geometry
    ipNewGeometryColl.AddGeometryCollection ipGeometry
  Next
  Set PathPolyLine = m_ipPolyline
  
End Function


Private Sub MapControl1_OnMouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)
  Dim ipNew As IPoint
  Dim pActiveView As IActiveView
  
  Set pActiveView = MapControl1.Map
  If m_ipPoints Is Nothing Then
    Set m_ipPoints = New Multipoint
    
  End If
  Set ipNew = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  
  m_ipPoints.AddPoint ipNew
  Dim i As Integer
  i = m_ipPoints.PointCount
  
End Sub