基于ArcGIS VBA的宗地四至生成法1

一种宗地四至自动赋值的方法探究作者：蒋思思刘正才阳德志来源：《现代农业科技》2019年第21期摘要; ; 农村土地经营权确权项目关乎民生，项目中需要确权的农村土地不仅数据量大，而且形状各异。

其中，宗地四至的信息录入，人工识别效率低且容易出错，若利用现有的地理信息软件工具进行二次开发，实现宗地四至自动赋值，将有效提高效率、降低出错率。

笔者探讨了基于ArcGIS Engine的二次开发，用最长界址线法来自动获取宗地四至信息，该方法已经运用到湖南省常德市桃源县农村承包经营权确权登记项目中，达到了一定的效果。

关键词; ; 宗地四至;自动赋值;ArcGIS Engine;最长界址线法中图分类号; ; S159; ; ; ; ;文献标识码; ; A文章编号; ;1007-5739（2019）21-0262-02; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;开放科学（资源服务）标识码（OSID）Abstract; ; The project of confirming the right of rural land management concerns people′s livelihood. The rural land that needs confirming right in the project not only has a large amount of data， but also has different shapes.Among them，the manual input of the information from the relative location of adjoining parcels is inefficient and error-prone.If the existing geographic information software tools were used for secondary development to realize the automatic assignment of the relative location of adjoining parcels，the efficiency will be effectively improved and the error rate will be reduced.This paper discussed the secondary development based on ArcGIS Engine，and used the longest boundary line method to automatically obtain the information of the relative location of adjoining parcels.This method has been applied to the registration project of rural contractual management rights in Taoyuan County，Changde City，Hunan Province，and has achieved certain results.Key words; ; relative location of adjoining parcels;automatic assignment;ArcGISEngine;maximum public edge length method經营权是指农村集体经济组织成员或者农村集体经济组织以外的单位或个人依法对其承包经营的集体所有或国家所有由农民集体使用的农村土地享有占有、使用和收益的权利。

如何生界址点一、打开土地确权软件。

二、读取地块数据库。

三、单击“数据视图”（下方）四、点“选择要素”全部选中数据库地块，点击（上面）界址点处理------界址点线生成点距离最小值1或0.5垂距设置1或1.5夹角最大值170度再点击“提取界址点”，生完后点“写入界址点数据库。

五、双击工具条上的Arctoolbox------分析工具------叠加分析------空间连接，再点“目标要素”后的文件夹图标，点小黑三角填“DK”，再点“连接要素”后文件夹图标，点小黑三角填“JZD”，再点“输出要素”后文件夹图标，找到生界址点数据库，名称填个英文字母（任意）------保存------确定。

删除界址点一、把地块在内容列表下“按选择列出”里，点为灰色不可选，JZD点为天兰色（可选），选择JZD------编辑要素------开始编辑。

右键DK，打开属性表，一块一块删除界址点。

删除时用鼠标拉框选中界址点，按键盘上的delete键即可，随时保存。

如何生四至一、打开土地确权软件。

二、读取地块数据库。

找到要做的数据库------打开------否。

左边选中生四至的村小组名称------点下面的“原始数据”-------“不需要赋值”------位置排序------更新地块数据库------更新地块编码-----确定。

三、点下面“数据视图”------左边“选择要素”全部选中数据库地块，点上面“地块四至”------自动查找，然后“地块图层”里填“DK”,设置宗地缓冲查找距离里填1.2，设置线状地物查找距离为空。

四、点“开始查找”------确定，左边点“添加数据”------栅格-----找到要添加的影像添加进去，然后再点“添加数据”------地理数据库，再把总库添加进去五、点“标注”------标注设置，图层里要添总库“DK”，再在“标注字段”里双击“XZMC”(小组名称)，颜色自由选填。

六、点“编辑器”------开始编辑------“地块四至”------逐快浏览检查七、选中一块地，分别看东西南北四至对不，，不对在正确位置点一下鼠标，再在相应四至关系位置上点一下。

'基本思想：求取地块中心点，以中心点向正南正北正西正东发送射线，求取与四条线相交的四个地块即为四至地块Private Sub CommandButton1_Click()Dim pMxDoc As IMxDocument '代表本文档数据Dim pMap As IMap '代表激活的地图Dim pFeaLayer As IFeatureLayer '代表地图中的图层，这里仅有一个Dim pFeaClass As IFeatureClass '代表图层中的要素类数据Dim pQueryF1 As IQueryFilter '查询条件1Dim pQueryF2 As IQueryFilter '查询条件2Dim pFeaCursor1 As IFeatureCursor '要素游标1，提取要素数据使用Dim pFeaCursor2 As IFeatureCursor '要素游标2，提取要素数据使用Dim pFeature1 As IFeature '要素1对应变量Dim pFeature2 As IFeature '要素2对应变量Dim pRelation As IRelationalOperator '空间关系分析使用Dim pTopo As ITopologicalOperator '求交空间分析使用Dim pPoint As IPoint '存储对象中心点Dim pArea As IArea '求取中心点辅助变量Dim pIntersectGeo As IGeometryDim pPoColl As IPointCollectionDim pDLine As IPolyline '东至水平线Dim pXLine As IPolyline '西至水平线Dim pNLine As IPolyline '南至水平线Dim pBLine As IPolyline '北至水平线Dim pTempLine As IPolyline '-------------------Dim pDPoint As IPoint '东至交点Dim pXPoint As IPoint '西至交点Dim pNPoint As IPoint '南至交点Dim pBPoint As IPoint '北至交点Dim Sizhi(4) As String '存储宗地四至信息Sizhi(0) = "暂无"Sizhi(1) = "暂无"Sizhi(2) = "暂无"Sizhi(3) = "暂无"On Error GoTo ErrorHandler://////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////Set pMxDoc = ThisDocumentSet pMap = pMxDoc.FocusMapSet pFeaLayer = /doc/7548681027d3240c8447efb6.html yer(0)Set pFeaClass = pFeaLayer.FeatureClassSet pQueryF1 = New QueryFilterSet pQueryF2 = New QueryFilterpQueryF1.WhereClause = "村组<>'" + "110'"'Set pFeaCursor1 = pFeaClass.Search(pQueryF1, False)'此为检索Set pFeaCursor1 = pFeaClass.Update(pQueryF1, False) '此为更新Set pFeature1 = pFeaCursor1.NextFeatureSet pPoint = New Point '中心点对象实例化Set pDPoint = New Point '交点对象实例化Set pXPoint = New Point '交点对象实例化Set pNPoint = New Point '交点对象实例化Set pBPoint = New Point '交点对象实例化Set pDLine = New Polyline '交线对象实例化Set pXLine = New Polyline '交线对象实例化Set pNLine = New Polyline '交线对象实例化Set pBLine = New Polyline '交线对象实例化Set pTempLine = New PolylineDo While Not pFeature1 Is Nothing'求取中点Set pArea = pFeature1.ShapepArea.QueryCentroid pPoint'延长线pDPoint.PutCoords pPoint.X + 10000, pPoint.YpXPoint.PutCoords pPoint.X - 10000, pPoint.YpNPoint.PutCoords pPoint.X, pPoint.Y - 10000pBPoint.PutCoords pPoint.X, pPoint.Y + 10000pDLine.FromPoint = pPointpDLine.ToPoint = pDPointpXLine.FromPoint = pPointpXLine.ToPoint = pXPointpNLine.FromPoint = pPointpNLine.ToPoint = pNPointpBLine.FromPoint = pPoint////////////////////////////////////////////////////////////////////////////////////////////////////// pBLine.ToPoint = pBPointSet pTopo = pFeature1.Shape'获取东至交点pDPoint.SetEmptySet pTempLine = pTopo.Intersect(pDLine, esriGeometry1Dimension)Set pTopo = pTempLineSet pPoColl = pTopo.BoundarypDPoint.PutCoords pPoColl.Point(1).X, pPoColl.Point(1).Y'获取西至交点'pXPoint.SetEmpty'Set pTempLine = pTopo.Intersect(pXLine, esriGeometry1Dimension)'Set pTopo = pTempLine'MsgBox pTempLine.IsEmpty'Set pPoColl = pTopo.Boundary'MsgBox pPoColl.PointCount'pXPoint.PutCoords pPoColl.Point(1).X, pPoColl.Point(1).Y'获取南至交点'pNPoint.SetEmpty'Set pTempLine = pTopo.Intersect(pNLine, esriGeometry1Dimension)'Set pTopo = pTempLine'Set pPoColl = pTopo.Boundary'pNPoint.PutCoords pPoColl.Point(1).X, pPoColl.Point(1).Y'获取北至交点'pBPoint.SetEmpty'Set pTempLine = pTopo.Intersect(pBLine, esriGeometry1Dimension)'Set pTopo = pTempLine'Set pPoColl = pTopo.Boundary'pBPoint.PutCoords pPoColl.Point(1).X, pPoColl.Point(1).YSet pFeaCursor2 = pFeaClass.Search(Nothing, False) '重置二次循环对象集Set pFeature2 = pFeaCursor2.NextFeatureDo While Not pFeature2 Is Nothing '000 Set pRelation = pFeature2.Shape '注意此处If pRelation.Touches(pDPoint) Then '若两者相贴，则进入'001MsgBox pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))'If (Dongzhi = 0 And Xizhi = 0 And Nanzhi = 0 And Beizhi = 0) Then '002 'Dongzhi = pPoint.X'Xizhi = pPoint.X'Nanzhi = pPoint.Y'Beizhi = pPoint.Y'Sizhi(0) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))//////////////////////////////////////////////////////////////////////////////////////////////////////'Sizhi(1) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))'Sizhi(2) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'Sizhi(3) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'Else 'If (pPoint.X > Dongzhi) Then '确定东至'Sizhi(0) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'End If'If (pPoint.X < Xizhi) Then '确定西至'Sizhi(1) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'End If'If (pPoint.Y < Nanzhi) Then '确定南至'Sizhi(2) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'End If'If (pPoint.Y > Beizhi) Then '确定北至'Sizhi(3) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人")) 'End If'End IfEnd If Set pFeature2 = pFeaCursor2.NextFeatureLoop 'pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("东至")) = Sizhi(0) 'pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("西至")) = Sizhi(1)'pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("南至")) = Sizhi(2)'pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("北至")) = Sizhi(3) pFeaCursor1.UpdateFeature pFeature1Set pFeature1 = pFeaCursor1.NextFeatureLoopExit SubErrorHandler:MsgBox Err.DescriptionEnd Sub '002 '001 '002基于ArcGIS VBA的宗地四至生成法1'-------------------------------------------基础配置----------------------------------------Dim pMxDoc As IMxDocument '代表本文档数据Dim pMap As IMap '代表激活的地图Dim pFeaLayer As IFeatureLayer '代表地图中的图层，这里仅有一个Dim pFeaClass As IFeatureClass '代表图层中的要素类数据'-------------------------------------------查询条件----------------------------------------Dim pQueryF1 As IQueryFilter '查询条件1Dim pQueryF2 As IQueryFilter '查询条件2Dim pFeaCursor1 As IFeatureCursor '要素游标1，提取要素数据使用Dim pFeaCursor2 As IFeatureCursor '要素游标2，提取要素数据使用Dim pFeature1 As IFeature '要素1对应变量Dim pFeature2 As IFeature '要素2对应变量'-------------------------------------------算法变量-----------------------------------------Dim iNameCount As Long '权利人数组存有的数目Dim iColumnCountStart As Long '起始输入的Excel行数Dim iColumnCountEnd As Long '结束输入的Excel行数Dim bIsNameExist As Boolean '标识当前权利人是否已写入Dim pName As String '当前权利人姓名Dim pNameArray() As String '已写入权利人姓名数组'----------------------------------------Excel数据写入准备-----------------------------------Dim xlapp As Excel.ApplicationDim xlbook As Excel.WorkbookDim xlsheet As Excel.WorksheetSet xlapp = CreateObject("excel.Application")Set xlbook = xlapp.Workbooks.Open("D:\实验表格.xls")xlapp.Visible = TrueSet xlsheet = xlbook.Worksheets(1)On Error GoTo ErrorHandler:iNameCount = 0iColumnCountStart = 5iColumnCountEnd = 5bIsNameExist = FalseSet pMxDoc = ThisDocumentSet pMap = pMxDoc.FocusMapSet pFeaLayer = /doc/7881f9bb05087632311212ae.html yer(0)Set pFeaClass = pFeaLayer.FeatureClass//////////////////////////////////////////////Set pQueryF1 = New QueryFilterSet pQueryF2 = New QueryFilter'-------------------------------------------写Excel表头--------------------------------------With xlsheet.Cells(1, 1) = "农村土地承包经营权调查信息公示表".Cells(3, 1) = "序号".Cells(3, 2) = "承包方" & Chr(13) & Chr(10) & "（代表）".Cells(3, 3) = "地块总体情况".Cells(3, 5) = "地块具体情况".Cells(3, 13) = "公示" & Chr(13) & Chr(10) & "备注".Cells(4, 3) = "合同" & Chr(13) & Chr(10) & "面积".Cells(4, 4) = "实测" & Chr(13) & Chr(10) & "面积".Cells(4, 5) = "地块" & Chr(13) & Chr(10) & "名称".Cells(4, 6) = "地块" & Chr(13) & Chr(10) & "编码".Cells(4, 7) = "东至".Cells(4, 8) = "南至".Cells(4, 9) = "西至".Cells(4, 10) = "北至".Cells(4, 11) = "合同" & Chr(13) & Chr(10) & "面积".Cells(4, 12) = "实测" & Chr(13) & Chr(10) & "面积".Range(.Cells(3, 1), .Cells(4, 13)).Borders.LineStyle = xlContinuous.Range(.Cells(1, 1), .Cells(4, 13)).HorizontalAlignment =Excel.XlHAlign.xlHAlignCenter .Range(.Cells(1, 1), .Cells(4, 13)).VerticalAlignment = Excel.XlHAlign.xlHAlignCenter.Range(.Cells(1, 1), .Cells(1,13))/doc/7881f9bb05087632311212ae.html = "黑体".Range(.Cells(1, 1), .Cells(1, 13)).Font.size = 14.Range(.Cells(3, 1), .Cells(4,13))/doc/7881f9bb05087632311212ae.html = "宋体".Range(.Cells(3, 1), .Cells(4, 13)).Font.size = 9.5.Range(.Cells(1, 1), .Cells(1, 13)).Merge.Range(.Cells(3, 1), .Cells(4, 1)).Merge.Range(.Cells(3, 2), .Cells(4, 2)).Merge.Range(.Cells(3, 3), .Cells(3, 4)).Merge.Range(.Cells(3, 5), .Cells(3, 12)).Merge.Range(.Cells(3, 13), .Cells(4, 13)).MergeEnd With'------------------------------------------------------------------------------------------'pQueryF1.WhereClause = "权利人='" + "黄永和'" '重置一次循环对象集，实验Set pFeaCursor1 = pFeaClass.Search(Nothing, False)Set pFeature1 = pFeaCursor1.NextFeatureDo While Not pFeature1 Is NothingpName = pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("权利人")) '获取当前权利人信息////////////////////////////////////If iNameCount <> 0 Then '001--判断是否已写入过此权利人For i = 1 To iNameCount '----------------002If pName = pNameArray(i) Then '003bIsNameExist = TrueEnd If '003Next i '----------------002End If '001--判断是否已写入过此权利人If bIsNameExist = False TheniNameCount = iNameCount + 1ReDim Preserve pNameArray(1 To iNameCount)pNameArray(iNameCount) = pName'---------------------------------------------pQueryF2.WhereClause = "权利人='" + pName + "'" '重置一次循环对象集，实验Set pFeaCursor2 = pFeaClass.Search(pQueryF2, False)Set pFeature2 = pFeaCursor2.NextFeatureDim iRightNum As IntegeriRightNum = 0Dim dTotalArea As DoubledTotalArea = 0#Do While Not pFeature2 Is NothingiRightNum = iRightNum + 1dTotalArea = dTotalAreapFeature2.Value(pFeature2.Fields.FindFieldByAliasName("Shape_Area"))'此处向excel写入数据，依据iColumnCountEndWith xlsheet.Cells(iColumnCountEnd, 5) = "" '地块名称.Cells(iColumnCountEnd, 6) = "" '地块编码.Cells(iColumnCountEnd, 7) =pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("东至")) .Cells(iColumnCountEnd, 8) =pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("南至")) .Cells(iColumnCountEnd, 9) =pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("西至")) .Cells(iColumnCountEnd, 10) =pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("北至")) .Cells(iColumnCountEnd, 11) = "" '合同面积.Cells(iColumnCountEnd, 12) =Format(pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("Shape_Area")) *0.0015, "0.00")End WithiColumnCountEnd = iColumnCountEnd + 1Set pFeature2 = pFeaCursor2.NextFeatureLoopWith xlsheet.Cells(iColumnCountStart, 2) = pName.Cells(iColumnCountStart, 3) = "" +//////////////////////////////////////////////////// .Cells(iColumnCountStart, 4) = "合计：".Cells(iColumnCountStart + 1, 4) = iRightNum & "块".Cells(iColumnCountStart + 2, 4) = Format(dTotalArea * 0.0015, "0.00") & "亩".Range(.Cells(iColumnCountStart, 1), .Cells(iColumnCountStart + iRightNum + 1, 1)).Merge .Range(.Cells(iColumnCountStart, 2), .Cells(iColumnCountStart + iRightNum + 1, 2)).Merge.Range(.Cells(iColumnCountStart, 1), .Cells(iColumnCountEnd + 2,13)).HorizontalAlignment = Excel.XlHAlign.xlHAlignCenter.Range(.Cells(iColumnCountStart, 1), .Cells(iColumnCountEnd + 2,13)).VerticalAlignment = Excel.XlHAlign.xlHAlignCenter.Range(.Cells(iColumnCountStart, 1), .Cells(iColumnCountEnd + 2,13))/doc/7881f9bb05087632311212ae.html = "宋体" .Range(.Cells(iColumnCountStart, 1), .Cells(iColumnCountEnd + 2, 13)).Font.size = 9.5 End With'此处合并单元格，依据iColumnCountStart、iRightNumiColumnCountStart = iColumnCountStart + iRightNum + 1 + 1iColumnCountEnd = iColumnCountEnd + 1 + 1End IfSet pFeature1 = pFeaCursor1.NextFeaturebIsNameExist = FalseLoopxlapp.ActiveWorkbook.Savexlapp.Workbooks.Closexlapp.QuitSet xlapp = NothingMsgBox "数据处理完成！"Exit SubErrorHandler:MsgBox Err.DescriptionEnd SubPrivate Sub CommandButton3_Click()Dim xlapp As Excel.ApplicationDim xlbook As Excel.WorkbookDim xlsheet As Excel.WorksheetSet xlapp = CreateObject("excel.Application")Set xlbook = xlapp.Workbooks.Open("D:\实验表格.xls")xlapp.Visible = TrueSet xlsheet = xlbook.Worksheets(1)With xlsheet.Cells(1, 1) = "农村土地承包经营权调查信息公示表".Cells(3, 1) = "序号".Cells(3, 2) = "承包方" & Chr(13) & Chr(10) & "（代表）".Cells(3, 3) = "地块总体情况"////////////////////////////////////////////.Cells(3, 5) = "地块具体情况".Cells(3, 13) = "公示" & Chr(13) & Chr(10) & "备注".Cells(4, 3) = "合同" & Chr(13) & Chr(10) & "面积".Cells(4, 4) = "实测" & Chr(13) & Chr(10) & "面积".Cells(4, 5) = "地块" & Chr(13) & Chr(10) & "名称".Cells(4, 6) = "地块" & Chr(13) & Chr(10) & "编码".Cells(4, 7) = "东至".Cells(4, 8) = "南至".Cells(4, 9) = "西至".Cells(4, 10) = "北至".Cells(4, 11) = "合同" & Chr(13) & Chr(10) & "面积".Cells(4, 12) = "实测" & Chr(13) & Chr(10) & "面积".Range(.Cells(3, 1), .Cells(4, 13)).Borders.LineStyle = xlContinuous.Range(.Cells(1, 1), .Cells(4, 13)).HorizontalAlignment =Excel.XlHAlign.xlHAlignCenter .Range(.Cells(1, 1), .Cells(4, 13)).VerticalAlignment = Excel.XlHAlign.xlHAlignCenter.Range(.Cells(1, 1), .Cells(1,13))/doc/7881f9bb05087632311212ae.html = "黑体".Range(.Cells(1, 1), .Cells(1, 13)).Font.size = 14.Range(.Cells(3, 1), .Cells(4,13))/doc/7881f9bb05087632311212ae.html = "宋体".Range(.Cells(3, 1), .Cells(4, 13)).Font.size = 9.5.Range(.Cells(1, 1), .Cells(1, 13)).Merge.Range(.Cells(3, 1), .Cells(4, 1)).Merge.Range(.Cells(3, 2), .Cells(4, 2)).Merge.Range(.Cells(3, 3), .Cells(3, 4)).Merge.Range(.Cells(3, 5), .Cells(3, 12)).Merge.Range(.Cells(3, 13), .Cells(4, 13)).MergeEnd Withxlapp.ActiveWorkbook.Savexlapp.Workbooks.Closexlapp.QuitSet xlapp = NothingEnd Sub基于ArcGIS VBA的宗地四至生成法3Private Sub CommandButton1_Click()'////////////////////////基础配置////////////////////////////////Dim pMxDoc As IMxDocument '代表本文档数据Dim pMap As IMap '代表激活的地图Dim pFeaLayer As IFeatureLayer '代表地图中的图层，这里仅有一个Dim pFeaClass As IFeatureClass '代表图层中的要素类数据'/////////////////////////////////////////////////////////////// Dim pQueryF1 As IQueryFilter '查询条件1Dim pQueryF2 As IQueryFilter '查询条件2Dim pFeaCursor1 As IFeatureCursor '要素游标1，提取要素数据使用Dim pFeaCursor2 As IFeatureCursor '要素游标2，提取要素数据使用Dim pFeature1 As IFeature '要素1对应变量Dim pFeature2 As IFeature '要素2对应变量Dim pPoint As IPoint '存储对象中心点Dim pArea As IArea '求取中心点辅助变量Dim pPoint2 As IPoint '求取对象2的中心点Dim pArea2 As IArea '求取对象2的中心点Dim pLineFea1 As IPolylineDim pLine As IPolylineDim pPoly As IPolygonDim pPoColl As IPointCollectionDim sSizhi(4) As String '存储宗地四至信息sSizhi(0) = "荒地" '东至sSizhi(1) = "荒地" '西sSizhi(2) = "荒地" '南sSizhi(3) = "荒地" '北Dim dSizhi(4) As Double '存储宗地四至坐标On Error GoTo ErrorHandler:Set pMxDoc = ThisDocumentSet pMap = pMxDoc.FocusMapSet pFeaLayer = /doc/e729880c1711cc7931b716b1.html yer(0)Set pFeaClass = pFeaLayer.FeatureClass////////////////////////////////////////////////////// Set pQueryF1 = New QueryFilterSet pQueryF2 = New QueryFilterpQueryF1.WhereClause = "权利人='" + "黄永和'" '重置一次循环对象集，实验'Set pFeaCursor1 = pFeaClass.Search(pQueryF1, False)'Set pFeaCursor1 = pFeaClass.Update(pQueryF1, False)Set pFeaCursor1 = pFeaClass.Update(Nothing, False)Set pFeature1 = pFeaCursor1.NextFeatureSet pPoint = New Point '中心点对象实例化Set pPoint2 = New Point '中心点2对象实例化Set pLineFea1 = New PolylineSet pLine = New Polyline'-----------------------------------------------------------------------------------------------Dim lNumFeat As LonglNumFeat = pFeaClass.FeatureCount(Nothing)Dim lNumNow As LonglNumNow = 0'-----------------------------------------------------------------------------------------------Do While Not pFeature1 Is Nothing'求取对象中心坐标Set pArea = pFeature1.ShapepArea.QueryCentroid pPointdSizhi(0) = pPoint.XdSizhi(1) = pPoint.XdSizhi(2) = pPoint.YdSizhi(3) = pPoint.Y'pQueryF2.WhereClause = "权利人<>'" + "黄永和'"pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("权利人"))pQueryF2.WhereClause = "权利人<>'"pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("权利人")) + "'"Set pFeaCursor2 = pFeaClass.Search(pQueryF2, False) '重置二次循环对象集，实验'Set pFeaCursor2 = pFeaClass.Search(Nothing, False) '重置二次循环对象集，针对全部数据Set pFeature2 = pFeaCursor2.NextFeatureDo While Not pFeature2 Is Nothing '000 + +/////////////////////////////////////////////////////////// Dim pTopo1 As ITopologicalOperator '面转为线Dim pTopo2 As ITopologicalOperatorSet pTopo1 = pFeature1.ShapeSet pLineFea1 = pTopo1.BoundarySet pTopo1 = pLineFea1Set pLine = pTopo1.Intersect(pFeature2.Shape, esriGeometry1Dimension)If pLine.IsEmpty = False ThenSet pArea2 = pFeature2.ShapepArea2.QueryCentroid pPoint2If (pLine.FromPoint.X + pLine.ToPoint.X) / 2 > dSizhi(0) And pPoint2.Y <IIf(pLine.FromPoint.Y < pLine.ToPoint.Y, pLine.ToPoint.Y, pLine.FromPoint.Y) And pPoint2.Y > IIf(pLine.FromPoint.Y > pLine.ToPoint.Y, pLine.ToPoint.Y, pLine.FromPoint.Y) Then '判读是否为东至dSizhi(0) = (pLine.FromPoint.X + pLine.ToPoint.X) / 2sSizhi(0) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))End IfIf (pLine.FromPoint.X + pLine.ToPoint.X) / 2 < dSizhi(1) And pPoint2.Y <IIf(pLine.FromPoint.Y < pLine.ToPoint.Y, pLine.ToPoint.Y, pLine.FromPoint.Y) And pPoint2.Y > IIf(pLine.FromPoint.Y > pLine.ToPoint.Y, pLine.ToPoint.Y, pLine.FromPoint.Y) Then '判读是否为西至dSizhi(1) = (pLine.FromPoint.X + pLine.ToPoint.X) / 2sSizhi(1) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))End IfIf (pLine.FromPoint.Y + pLine.ToPoint.Y) / 2 < dSizhi(2) And pPoint2.X <IIf(pLine.FromPoint.X < pLine.ToPoint.X, pLine.ToPoint.X, pLine.FromPoint.X) And pPoint2.X > IIf(pLine.FromPoint.X > pLine.ToPoint.X, pLine.ToPoint.X, pLine.FromPoint.X) Then '判读是否为南至dSizhi(2) = (pLine.FromPoint.Y + pLine.ToPoint.Y) / 2sSizhi(2) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))End IfIf (pLine.FromPoint.Y + pLine.ToPoint.Y) / 2 > dSizhi(3) And pPoint2.X <IIf(pLine.FromPoint.X < pLine.ToPoint.X, pLine.ToPoint.X, pLine.FromPoint.X) And pPoint2.X > IIf(pLine.FromPoint.X > pLine.ToPoint.X, pLine.ToPoint.X, pLine.FromPoint.X) Then '判读是否为北至dSizhi(3) = (pLine.FromPoint.Y + pLine.ToPoint.Y) / 2sSizhi(3) = pFeature2.Value(pFeature2.Fields.FindFieldByAliasName("权利人"))End IfEnd IfSet pFeature2 = pFeaCursor2.NextFeatureLoop '002 pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("东至")) = sSizhi(0)pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("西至")) = sSizhi(1)/////////////////////////////////////////////////////////// pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("南至")) = sSizhi(2) pFeature1.Value(pFeature1.Fields.FindFieldByAliasName("北至")) = sSizhi(3) pFeaCursor1.UpdateFeature pFeature1Set pFeature1 = pFeaCursor1.NextFeature'-------------------------------------------------lNumNow = lNumNow + 1TextBox1.Text = Str(lNumNow)'-------------------------------------------------Loop Exit Sub。

在ArcGIS中计算四至坐标，需要按照以下步骤进行操作：
1. 打开属性表：在图层上右键，选择“打开属性表”。

2. 添加字段：在属性表上，点击表选项，选择“添加字段”。

3. 设置字段名称和类型：在添加字段对话框中，设置字段名称，例如“东至”、“西至”、“南至”和“北至”，类型选择双精度。

4. 计算四至坐标：
* 东至坐标：选择“东至”字段，在字段计算器内解析程序选择Python，在下面输入“!shape!.extent.xmax”。

点击确定完成东至坐标的计算。

* 西至坐标：选择“西至”字段，在字段计算器内解析程序选择Python，在下面输入“!shape!.extent.xmin”。

点击确定完成西至坐标的计算。

* 南至坐标：选择“南至”字段，在字段计算器内解析程序选择Python，在下面输入“!shape!.extent.ymin”。

点击确定完成南至坐标的计算。

* 北至坐标：选择“北至”字段，在字段计算器内解析程序选择Python，在下面输入“!shape!.extent.ymax”。

点击确定完成北至坐标的计算。

5. 计算四至坐标结果：完成以上步骤后，即可得到每个要素的四至坐标值。

可以在属性表中查看计算结果。

以上是在ArcGIS中计算四至坐标的详细说明，供您参考。