基于CASS开发宗地四至属性的自动生成探讨

基于CASS开发宗地四至属性的自动生成探讨摘要：本文讲述了基于CASS开发宗地四至属性的自动生成的必要性；概述了宗地图的制作原理；分析了CASS软件的选进性及开发模式；讨论了程序设计的具体流程；具体分析了程序各模块的实现及典型模块程序代码；在现阶段具有一定的理论与实践意义。

关键词：CASS，宗地，VBA，四至属性土地登记工作中一个很重要的内容就是宗地图的制作，而宗地图四至属性的标注是宗地图制作的一项重要内容。

依据传统的做法，四至属性的标注需要查阅每一宗地的实际位置，手工录入到宗地属性或是标注在宗地图上，依据笔者实践生产经验，这项工作所需技术含量不高，但比较繁琐，需花费大量的人力、物力。

而基于CASS开发宗地四至属性的自动生成程序可以把大量人力、物力从繁琐的劳动中解脱出来，因此基于CASS开发宗地四至属性的自动生成程序在宗地图的制作中变得举足重要。

南方CASS是目前国内广泛使用的宗地图制作成图软件，因其功能强大，通俗易懂，便于操作且能与其他地籍相关软件进行数据无缝接口，被广泛应用于宗地图制作。

本文结合自身参与的集体土地所有权发证项目，探讨基于CASS开发宗地四至属性的自动生成，希望能给广大同行起到抛砖引玉的作用[1]。

1 宗地图概述宗地图是描述宗地位置、界址点线关系、相邻宗地编号的分宗地籍图，用来作为该宗土地产权证书和地籍档案的附图。

宗地图中包括[2]：(1)图幅号、地籍号、坐落(2)单位名称、宗地号、地类号和占地面积单位名称、宗地号、地类号和占地面积标注在宗地图的中部。

例如，某宗地的使用权属第六中学，宗地号为7，地类号为083(按城镇土地分类083为科教用地)，占地面积1 165．6㎡。

(3)界址点、点号、界址线和界址边长界址点以直径0．8mm的小圆圈表示，包含与邻宗地公用的界址点，从宗地左上角沿顺时针方向以1开始顺序编号，连接各界址点形成界址线，两相邻界址点之间的距离即为界址边长。

(4)宗地内建筑物和构筑物若宗地内有房屋和围墙，应注明房屋和围墙的边长。

一种宗地四至自动赋值的方法探究作者：蒋思思刘正才阳德志来源：《现代农业科技》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經营权是指农村集体经济组织成员或者农村集体经济组织以外的单位或个人依法对其承包经营的集体所有或国家所有由农民集体使用的农村土地享有占有、使用和收益的权利。

农村土地承包经营权地块四至自动提取的方法研究摘要：农村土地承包经营权确权登记工作中，地块四至关系的逻辑性和准确性尤为关键，涉及到权利人的根本利益，并且直接决定了登记发证的顺利与否。

针对传统人工判断、录入地块四至的弊端，研究对比了四种宗地四至提取方法，在ArcGIS平台支持下，开发相关程序，可以方便快捷的实现地块四至信息的自动判断和录入，为土地确权登记工作节省了大量人力和时间，提高了工作效率和数据的准确性。

关键词：土地确权登记；地块；四至；ArcGIS1 引言土地承包经营权是指农村集体经济组织成员或者农村集体经济组织以外的单位或个人依法对其承包经营的集体所有或国家所有由农民集体使用的农村土地享有占有、使用和收益的权利。

承包地块，是由土地承包经营权界线所封闭的地块[1]。

四至，则是每宗地四邻的名称[2]，应填写对应的农村土地权利人姓名或地物名称[1]。

对地块四至的提取是确定土地权属的一项重要内容，而地块四至关系的逻辑性和准确性尤为关键，涉及到权利人的根本利益[3]，并且直接决定了登记发证的顺利与否[3]。

2 自动提取方法对地块四至的采集和录入是一项费时而繁琐的工作[4]，传统的方法是通过人工判断，然后手工输入到属性表中，这取决于作业员的主观认识，效率低、易出错；文献[3]提供了基于ArcGIS Engine 10.0二次开发的四至录入插件，可以实现半自动并带有人工判读的录入方式；有些CAD插件提供了生成宗地四至的功能，但是它们生成宗地四至的方法需要手工提前输好CAD的扩展属性信息，如手工提前输入的界址线邻宗地号信息等[5]；部分GIS软件能够提取宗地的四至信息并写入宗地数据的属性表，但是软件的费用高，数据格式兼容性低，数据的安全性也得不到保障[5]。

基于ArcGIS二次开发的方法较多，主要有中心点射线提取法、最小外接矩形提取法、交界线提取法、重心连线方位角提取法。

2.1 中心点射线提取法中心点射线提取法首先获取地块的中心点，然后从中心点出发引出东、南、西、北四条射线，最后搜索与对应射线相交的相邻地块，从而得到本地块的四至。

四至点加强版使用说明书土地复垦独家软件群 72493862 一．安装1.先安装.NetFramework.4.02.点击“自动安装”3.点击一键安装二．卸载点击一键卸载三．加载打开cad或者cass时，将自动加载“土地整理”菜单栏温馨提示：Cad和Cass相互切换，所有功能和命令正常使用。

如果菜单栏不显示，输入命令：getmenus，立即出现菜单栏。

四．功能介绍温馨提示：生成内容在当前图层。

1.生成四至点1.1或者输入命令fop1.2 选择需要生成四至点的红线。

1.3 选择生成四至点表格放置的位置。

1.4如果设置为Bylayer，生成内容的颜色和当前图层颜色一致。

将表格选中设为Byblock，表格即变为黑色。

温馨提示：这种功能更加适用于单个图，如果你是先做的一张总图，那么，下面的“批量生成四至点”将为你带来更多快捷，节省更多时间。

2.批量生成四至点2.1或者输入命令fops2.2选择需要生成四至点的红线。

支持点选，框选。

2.3空格或enter键确认后，无需等待，自动批量生成。

2.4 批量生成的表格位置在每个红线最北（D点）的正上方。

2.5如果设置为Bylayer，生成内容的颜色和当前图层颜色一致。

利用“快速选择”将表格选中，设为Byblock，表格即变为黑色。

温馨提示：仅打开四至点和红线2个图层。

将四至点设为当前图层，一次框选即完成批量生成。

3 生成图框坐标（排成行的打印版同样适用）3.1 或者输入命令labxy3.2 选择你需要生成图框四角坐标的内图框。

3.33.3.1默认为N不偏移。

如果图框所在位置为正确的坐标位置，直接空格或者enter健确认即可。

3.3.2如果你们单位是排成行的打印版，没有问题。

请选择Y选择正确地理位置上的红线。

选择打印位置上的红线。

软件自动计算偏移量，生成的图框坐标和放在正确地理位置上坐标一致。

温馨提示：“生成图框坐标”功能的最大优势：你再不必每个片块去生成图框。

提前做好公司常用的图框模板。

'基本思想：求取地块中心点，以中心点向正南正北正西正东发送射线，求取与四条线相交的四个地块即为四至地块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。

基于GIS的农地四至自动计算方法作者：康念坤吴少华来源：《中国房地产业·下旬》2020年第08期【摘要】针对当前农地调查工作中农地四至计算存在的准确率低、自动化程度不高等问题，结合GIS空间分析原理与方法，提出一种高效的农地四至自动计算方法。

利用构建的方向搜索线段和搜索区间，获得农地四周的四至信息，其中搜索线段可以快速获取四至信息，同時以搜索区间为补充，进一步提高四至计算的准确率。

最后，通过实例数据验证和对比分析，表明本文所提方法与现有软件的四至计算功能相比，无论是从时间效率，还是准确率方面，都有很大的提高。

【关键词】农地调查;农地四至;GIS;空间分析1、引言农地是指具有封闭权属界线的地块，是地球表面有确定的边界和权属的土地[1]。

农地四至是指某一农地四个方向与相邻土地的交接界线，通常填写四邻的土地所有者或使用单位和个人的名称[2-3]。

农地四至的确定，一是为了快速界定农地的范围，二是为了在农地管理中快速检索出农地的位置信息。

目前，现有农地调查建库软件针对农地四至自动计算与提取功能实用性不强，在实际工作过程中，农地四至更多是依靠外业人工判读，再手动输入到入库属性表中。

采用人工判断+手动输入模式确定四至信息，势必导致其受人为因素的干扰，无法保证四至信息的准确性和完整性。

基于此，本文提出一种基于GIS的农地四至自动计算方法。

利用GIS强大的空间分析功能，以农地几何和属性数据为基础，构建空间搜索线段和搜索区间，快速、准确、高效地获取农地四至信息[6-9]，在很大程度上提高了农地调查工作的效率。

2、农地四至计算方法及流程2.1 农地四至计算基本思想农地四至信息的获取是对目标农地东、南、西、北四个方向进行搜索，得到每个方向上最合理的邻接农地。

对于不规则的农地，四至信息难以判别时，则利用GIS空间分析中的缓冲区思想，通过设定目标地块的搜索区间，在构建的搜索区间内判定该地块的四至邻接地块。

基本思想是：以待计算四至信息的农地为目标地块，计算该农地的最小外包矩形，再以目标地块的几何中心作为起算点，平行于坐标轴构建东、南、西、北四个方向直线段，得到直线段与目标地块边界的交点;然后以交点为起点向外延伸一段缓冲距离，形成各自方向上的搜索线段，利用GIS空间查询分析，分别计算出与各方向搜索线段相交的农地集合，将几何中心距离目标地块最近的农地要素，作为目标地块的某一四至信息。

基于ArcEngine平台的宗地四至自动生成方法研究摘要：宗地是地籍调查和土地确权登记等工作的基本土地单元，在地籍测绘和土地确权等工作中，获取宗地四至信息是必不可少的一环。

传统的宗地四至信息首先需要人工判断，然后依据判断结果手工输入到属性表中，这样不仅工作效率低，也容易在人工输入过程中产生错误。

该文针对传统人工判断、输入宗地四至信息的弊端，提出了三种宗地四至提取方法，在ArcGIS平台支持下，使用VB 语言开发了宗地四至自动提取程序，该程序可以方便快捷的实现宗地四至信息的自动判别、自动输入，为地籍调查、土地确权登记等工作节省了大量人力和时间，大大提高了工作效率和数据的准确性。

关键词：宗地；宗地四至；人工；自动化P208 A 1007-7731（2016）13-0032-04宗地是地籍调查单元，为土地权属界址线所封闭的地块，即地籍调查和土地登记的基本土地单元。

四至是每宗地四邻的名称，地籍调查规程中规定，宗地四至应填写相邻宗地的土地使用权人、所有权人名称；与道路、河流等线状地物相邻的应填写地物名称；与空地、荒山、荒滩等未确定使用权的国有土地相邻的，应准确描述相应地物、地貌的名称。

目前，国土建库方面的软件都未能提供较好地宗地四至提取方法。

在地籍数据入库过程中，宗地四至常常先是通过人工判断，然后手工输入到属性表中，这样不仅工作效率低下，也容易造成手工输入错误。

尽管有些 CAD插件提供了生成宗地四至的功能，但是它们生成宗地四至的方法需要手工提前输好CAD的扩展属性信息，如手工提前输入的界址线邻宗地号信息等。

另外，CAD作业方法不符合地籍建库的要求。

2012年开展的农村集体土地确权登记发证工作工期紧、任务重，为保证项目按时、保质、保量的完成，需要优化传统作业流程，充分利用每个阶段的已有成果，节约人力，提高工作效率。

1 研究现状1.1 传统获取方法获得一块宗地的四至就是对一个宗地的邻宗地进行搜索，怎么才能正确地判断出一块宗地的北边、东边、南边、西边，笔者采取宗地左上角和右上角之间的邻宗地判定为北至，宗地右上角和右下角界址点之间的邻宗地判定为东至，宗地右下角和左下角界址点之间的邻宗地判定为南至，宗地左下角和左上角界址点之间的邻宗地判定为西至。

基于arcgis的宗地四至自动提取方法随着城市化进程的不断加快，宗地的管理和维护变得愈加重要。

在进行宗地规划、土地资源管理、农村土地承包等工作中，宗地四至的准确测绘和自动提取是必不可少的环节。

传统的宗地四至测绘方法费时费力，精度不高，而基于ArcGIS的宗地四至自动提取方法则能够提高工作效率和精度，是城市土地管理中的重要工具。

一、基于ArcGIS的宗地四至自动提取方法的基本流程（1）数据预处理：首先需要将宗地数据和相应的地形图数据导入到ArcGIS软件中，进行数据预处理。

可以通过数据清理、数据合并、数据切片等方式，对数据进行必要的处理和整合，确保数据集的完整性和准确性。

（2）坐标匹配：针对导入的宗地图数据和地形图数据，需要进行坐标匹配。

通过坐标匹配，可以确定各个图层之间的空间关系，确定宗地边缘节点，并建立宗地四至自动识别的基础数据。

（3）线性识别：对于建立好的基础数据进行线性识别。

通过线性识别，可以识别出宗地的四边形形态，并对其进行边缘线的提取和简化。

线性识别的过程中，需要注意对宗地边际节点的识别和判定，以保证提取出的宗地四至正确无误。

（4）面积计算：通过线性识别和边缘提取得到宗地多边形的边缘点，基于此可以计算出宗地的面积。

在面积计算的过程中，需要注意边缘线的折线性，减少误差的产生。

（5）输出结果：最后将处理好的数据进行输出，并以图形方式呈现，提高数据的可读性和直观性。

同时，为了方便在地理信息系统中使用，也可以将数据导出为恰当的文件格式，如dwg等。

二、基于ArcGIS的宗地四至自动提取方法的优点（1）高效快捷：利用基于ArcGIS的宗地四至自动提取方法，可以节省大量时间和人力成本。

通过自动提取方法，能够更快捷、精准地完成宗地四至的提取，故而提高了工作的效率。

（2）准确性高：传统的宗地四至测绘方法在实践中存在精度不高的问题。

而基于ArcGIS的宗地四至自动提取方法可以有效提高提取结果的精度。

始终保证了数据的准确性，避免了由于数据误差带来的工作效率低下和结果不可信的问题。