Arcgis vba 点构面 polygon ring 涉及 环 岛

第一次写VBA 有点不惯 尤其涉及对象引用要用Set  while wend 

 

一股脑全写了 面条到底  没重构 有好多重复代码

 

mxd保存了 发给人家还不知能不能复用 

 

问题是： 一堆坐标 有序 一个地块包含多个环

 

内环或洞 顺时针

岛或外环 逆时针

 

自动构建地块

 

解决思路：Excel数据 有5列 地块号，X，Y，环号列（每个地块有n个环，环号依次是1,2...n）， 内外环（0为内环，1为外环）

 

通过Arcmap Add XY Data 导入Excel生成临时图层导出生成实际图层

 

arcCatalog 创建面图层 都加载到arcmap中  ok

 

写代码 运行

 

效果：

 

 

代码如下：

'点图层在上，面图层在下 Dim pMxdoc As IMxDocument Set pMxdoc = ThisDocument Dim pMap As IMap Set pMap = pMxdoc.FocusMap Dim pPointLayer As IFeatureLayer Set pPointLayer = pMap.Layer(0) Dim pPolygonLayer As IFeatureLayer Set pPolygonLayer = pMap.Layer(1) Dim groupFieldIndex As Integer Dim ringFieldIndex As Integer Dim directionFieldIndex As Integer Dim pTable As ITable Set pTable = pPointLayer.FeatureClass groupFieldIndex = pTable.FindField("地块圈号") ringFieldIndex = pTable.FindField("环号") directionFieldIndex = pTable.FindField("内外环") Dim pQFilter As IQueryFilter Set pQFilter = New QueryFilter pQFilter.WhereClause = "FID >= 0" Dim myCursor As IFeatureCursor Set myCursor = pPointLayer.FeatureClass.Search(pQFilter, True) Dim pFeature As IFeature Set pFeature = myCursor.NextFeature Dim currentGroupIndex As Integer Dim currentRingIndex As Integer Dim currentDirection As Integer currentDirection = -1 Dim currentFeature As IFeature Dim currentPolygon As IPolygon Dim currenRing As IRing While Not pFeature Is Nothing If currentGroupIndex < pFeature.Value(groupFieldIndex) Then If currentGroupIndex > 0 Then currenRing.Close If currentDirection = 1 Then If currenRing.IsExterior = False Then currenRing.ReverseOrientation End If Else If currenRing.IsExterior = True Then currenRing.ReverseOrientation End If End If currentFeature.Store End If currentGroupIndex = pFeature.Value(groupFieldIndex) currentRingIndex = pFeature.Value(ringFieldIndex) currentDirection = pFeature.Value(directionFieldIndex) Dim point As IPoint Set point = pFeature.Shape Set currenRing = New ring Dim pointCollection As IPointCollection Set pointCollection = currenRing pointCollection.AddPoint point Set currentPolygon = New polygon Dim pGeometryCollection As IGeometryCollection Set pGeometryCollection = currentPolygon pGeometryCollection.AddGeometry currenRing Set currentFeature = pPolygonLayer.FeatureClass.CreateFeature Dim geometry As IGeometry Set geometry = currentPolygon Set currentFeature.Shape = geometry Else If currentRingIndex < pFeature.Value(ringFieldIndex) Then If currentRingIndex > 0 Then currenRing.Close If currentDirection = 1 Then If currenRing.IsExterior = False Then currenRing.ReverseOrientation End If Else If currenRing.IsExterior = True Then currenRing.ReverseOrientation End If End If End If currentRingIndex = pFeature.Value(ringFieldIndex) currentDirection = pFeature.Value(directionFieldIndex) Dim point2 As IPoint Set point2 = pFeature.Shape Set currenRing = New ring Dim pointCollection2 As IPointCollection Set pointCollection2 = currenRing pointCollection2.AddPoint point2 Dim pGeometryCollection2 As IGeometryCollection Set pGeometryCollection2 = currentPolygon pGeometryCollection.AddGeometry currenRing End If Dim pPoint As IPoint Set pPoint = pFeature.Shape Dim pPointCollection As IPointCollection Set pPointCollection = currenRing pPointCollection.AddPoint pPoint End If Set pFeature = myCursor.NextFeature Wend currenRing.Close If currentDirection = 1 Then If currenRing.IsExterior = False Then currenRing.ReverseOrientation End If Else If currenRing.IsExterior = True Then currenRing.ReverseOrientation End If End If currentFeature.Store pMxdoc.ActiveView.Refresh