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

格式：docx
大小：34.67 KB
文档页数：18

下载文档原格式

如何生界址点四至

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

二、读取地块数据库。

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

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

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

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

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

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

二、读取地块数据库。

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

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

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

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

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

基于GIS的农地四至自动计算方法

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

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

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

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

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

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

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

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

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

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

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

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

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

宗地四至的自动获取

宗地四至的自动获取摘要：对地籍数据处理，在AutoCAD和ArcGIS软件中用VBA实现对宗地四至属性的自动获取。

文章提出正确找出四至拐点的方法，以作为进一步获得四至属性的基础。

关键词：土地详查；农村承包地；宗地四至；VBA做了多个地籍相关的项目，比如国土二次调查、村庄地籍、农村承包地等，都涉及到宗地四至属性的赋值。

项目中用过不少地籍相关的软件，其中也都有宗地四至的自动获取。

但是从作业结果来看，都不尽理想，包含的错误较多，往往到填写调查表的时候，宗地四至的属性数据都需要人工检查、甚至重新录入一遍，耗时耗工。

为了让自动获取的数据更有效，减少人工干预的工作量，本文对宗地四至的获取提出了一些自己的做法。

一、设计思想宗地四至的获取，关键就在对宗地四至位置的判别：一个临近对象到底是在宗地（目标对象）的东南西北哪个方向。

判断方向的方法有多种，随之产生的结果也会带来不同的问题。

这里，我们先判断出四至拐点（如图1），然后判断临近对象在哪两个拐点内，从而判断其归属哪一至或者哪几至。

图1二、数据准备四至的判断，涉及空间关系，对数据本身的要求也是比较高，按照整理地籍数据的流程上来说，都是在数据空间拓扑检查无错、基本属性赋值后再来处理，宗地数据和地类数据本身不要有重复点、悬挂点。

至于说在GIS软件（比如国土二调和村庄地籍）还是在CAD软件（比如农村承包地）中实现，总体思想上差不多，在细节处理上略有不同，比如临近对象获取：GIS软件可以通过目标对象构建缓冲区的面相交来获得，而CAD中则用缓冲区外边线的线相交来获得。

宗地外的地类，可以当成宗地处理，只是把权利人当成沟渠、道路、巷道这类。

三、实现流程1、获取要处理的目标对象。

通过图层选择的方法，可以获得宗地层所有对象，遍历每一个宗地，逐个处理。

一般来说，需要获取宗地的坐标集，和地籍号、权利人等属性。

2、根据宗地坐标集，确定四至拐点。

以西北拐点为例，判断哪个点是西北拐点，也就是图形的左上角点。

ArcGIS宗地四至辅助录入功能的插件式实现

ArcGIS宗地四⾄辅助录⼊功能的插件式实现
和类似的⼯具，⽤于辅助精细化作业。

本⼯具采⽤了“贴膜”的⽅式在ArcMap地图窗⼝上嵌⼊了⼀层透明窗体展⽰提⽰信息，并使⽤hook窗体消息的⽅法在ArcMap 窗体调整时动态对“膜”的⼤⼩进⾏调整。

⼀、⼯具功能
⼯具启⽤后，先选择⽬标图斑，然后开始按“北->东->南->西”的顺序依次点击邻斑，拾取其QLR字段的信息（显⽰到ArcMap 地图窗⼝右上⾓），拾取完毕，按空格键（space）将拾取的四⾄信息写⼊⽬标图斑的四⾄字段（BZ、DZ、NZ、XZ）。

如果中途拾取错误，需重新拾取，按Esc键重新开始；
如果⽬标图斑不存在邻斑，可以使⽤数字键0-9键⼊预设地物信息（如果不是需要的，可以后⾯⾃⾏批量替换）：
1=>"空地",
2=>"道路",
3=>"河流",
4=>"⼩巷",
5 => "林地",
6 => "居民地",
7 => "园地",
8 => "湖泊",
9 => "⽔库",
0 => "池塘",
后⾯或许会把预设地物信息改为由外部⽂件获取。

基于ArcEngine平台的宗地四至自动生成方法研究[权威资料]

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

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

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

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

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

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

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

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

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

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

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

基于arcgis的宗地四至自动提取方法

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

基于ArcGIS模型构建器的宗地四至自动提取方法

基于ArcGIS模型构建器的宗地四至自动提取方法
甘亚军;董正国
【期刊名称】《测绘技术装备》
【年(卷),期】2022(24)4
【摘要】地籍测绘项目中,准确获取宗地四至是一个重要且工作量较大的工作环节。

人工提取宗地四至效率较低,且提取准确率受作业员判别能力影响较大。

采用行业
中已有的软件自动提取宗地四至不一定适应项目的特殊需求,采用编程语言开发自
动提取工具对不具备编程能力的地籍测绘人员也存在困难。

针对上述难题,本文研
究了一种基于ArcGIS模型构建器的宗地四至自动提取方法。

该方法提取速度快、准确率高,无需编程即可实现宗地四至的批量提取。

【总页数】5页(P6-10)
【作者】甘亚军;董正国
【作者单位】广东省国土资源测绘院
【正文语种】中文
【中图分类】P271
【相关文献】
1.基于ArcEngine平台的宗地四至自动生成方法研究
2.基于AutoCAD二次开发
的宗地四至提取方法研究3.基于ArcObjects二次开发的宗地四至快速提取方法的实现与改进4.基于ArcGIS模型构建器的矢量数据自动化拓扑检查方法5.基于ArcGIS的宗地四至自动提取方法
因版权原因，仅展示原文概要，查看原文内容请购买。

基于ArcEngine平台的宗地四至自动生成方法研究

基于ArcEngine平台的宗地四至自动生成方法研究作者：薄鑫丁念邱赵爽秦畅席辉鲁立江来源：《安徽农学通报》2016年第13期摘要：宗地是地籍调查和土地确权登记等工作的基本土地单元，在地籍测绘和土地确权等工作中，获取宗地四至信息是必不可少的一环。

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

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

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

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

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

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

利用ArcGis软件自动维护田块四至的一种方法

利用ArcGis软件自动维护田块四至的一种方法作者：张静月来源：《农村经济与科技》2016年第17期[摘要]农村土地承包经营权确权工作在电子信息录入中有一项要求对田块四至信息的采集和准确录入，工作任务繁重且易错，如何利用计算机自动维护计算的功能快速准确地录入相应四至信息，对快速推进本工作有着极其重要的作用。

通过笔者探索，利用arcgis与excel软件的相关功能，可以实现快速自动输入，具体是：在 arcgis图斑矢量化初步完成后，通过输入承包方预编码及采集编制农户信息excell表，采用excell挂接功能将权属信息添加至数据库，将图斑统一编号并在属性表中新增X、Y、Xmax、Xmin、Ymax、Ymin六个特征字段，图斑按最小旋转角度转正至接近南北方向，利用python语句计算新增字段特征值后，导出属性表，将特征字段坐标按不同规则组合并制作成四至属性挂接excel表，再次采用excell挂接功能以基于图斑编号为基础字段，反挂接至原数据库，可以获得带田块四至属性的数据库。

[关键词]ArcGis软件；四至；坐标；属性挂接[中图分类号]P208 [文献标识码]A1 图斑四至要求1.1 四至属性填写要求农村土地承包经营权确权工作中需明确地块的四至属性，就是数据库录入时在东至、南至、西至和北至四个相应字段中填写某地块四邻的土地经营者或使用者单位和个人名称。

若毗邻的土地为道路、河流等线状地物或湖泊、山峰等，其四至填写为相关地物的名称，如××路，××河，××湖、××山等。

因田块地地籍图上以图斑形式存在，因此又称为地块图斑四至属性。

1.2 arcgis图斑四至属性结构建库要求为了方便利用arcgis软件的空间计算功能，在图斑四至属性建库时，需要在arcgis属性表中分别建立六个文本属性字段和六个双精度属性字段。

其中文本属性字段为承包方姓名、承包方预编码、东至、南至、西至、北至和图斑编号，分别填写本田块承包经营者的姓名、5位承包方代码（由2位村组编码和3位农户顺序码组成，在某村中承包方代码就每个承包方来讲是唯一的）、与图斑相邻的不同方向承包经营者的名称或毗邻地物的名称及本村数据库中地块图斑的五位编号（在某一村中图斑编号由计算机依arcgis语句自动编号，就本块图斑来讲编号是唯一的）；六个双精度属性字段为X、Y、Xmin、Xmax、Ymin、Ymax，分别填写在横轴墨卡托投影下本地块图斑最小外包矩形图斑中心点X坐标、Y坐标、最小X范围坐标（西坐标）、最大X范围坐标（东坐标）、最小Y范围坐标（南坐标）与最大Y范围坐标（北坐标）2 技术路线2.1 技术路线分析初步矢量化图斑完成后，利用arcgis软件中与excell表中特定字段的属性挂接功能、数据转换工具、空间属性联接功能和特定语句计算功能，通过赋值计算出地块图斑四至属性。

arcgis提取四至点坐标

arcgis提取四至点坐标概述arcgis是一款常用的地理信息系统（GIS）软件，可以用于空间数据的管理、分析和可视化。

在实际应用中，经常需要从地图中提取某个区域的四至点坐标，即该区域的最左边、最右边、最上边和最下边的点的坐标。

本文将详细介绍在arcgis中如何提取四至点坐标，并给出具体步骤和示例。

准备工作在开始之前，我们需要准备以下材料： 1. 安装arcgis软件，并确保已经激活。

2. 要提取四至点坐标的地图数据。

步骤一：加载地图数据首先，我们需要将要提取四至点坐标的地图数据加载到arcgis中。

可以通过以下步骤完成： 1. 打开arcgis软件，并创建一个新的地理数据库（Geodatabase）。

2. 在地理数据库中创建一个新的要素类（Feature Class），并选择合适的几何类型（如点、线或面）。

3. 将地图数据导入到新创建的要素类中。

步骤二：选择区域接下来，我们需要在加载好的地图数据中选择要提取四至点坐标的区域。

可以通过以下步骤完成： 1. 在arcgis的工具栏中选择“选择”工具。

2. 在地图上点击并拖动鼠标，框选出要提取四至点坐标的区域。

步骤三：提取四至点坐标一旦选择了要提取四至点坐标的区域，我们就可以开始提取四至点坐标了。

可以通过以下步骤完成： 1. 在arcgis的工具栏中选择“数据管理”工具集。

2. 打开“计算几何特征”工具。

3. 在弹出的对话框中，选择刚才创建的要素类作为输入数据源。

4. 在“输出字段”部分添加一个新的字段，并选择合适的字段类型（如文本）。

5. 点击“确定”按钮开始计算几何特征。

步骤四：查看结果完成计算几何特征后，我们可以查看提取到的四至点坐标。

可以通过以下步骤完成：1. 在arcgis的工具栏中选择“查询和选择”工具集。

2. 打开“属性表”工具。

3. 在属性表中找到刚才添加的新字段，并查看其中的数值。

示例假设我们有一张包含城市边界信息的地图数据，我们希望提取某个城市区域（例如北京市）的四至点坐标。

1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。

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