GIS VBA 创建界址点要素

江苏省地质测绘院 姜法明

本文介绍ArcMap VBA二次开发创建界址点的方法，宗地图层（面要素）有6426个宗地（要素），共有节点714403个，利用数据切片技术筛选重合点，得到 390994 个界址点。自动创建并加载界址点的Shape文件，在界址点图层中创建界址点要素。

1. 数据切片筛选界址点

利用IGeoDataset接口的IEnvelope 属性获取宗地图层的外框坐标，创建切片区域。

利用TableSort 接口获取面要素记录按宗地号排序的游标，历遍面要素，获取所有节点，筛选重合点，并把重合点的宗地号添加到保留的界址点上。参见上一编《GIS VBA 使用数据切片技术删除重合点》。

2.新建界址点的Shape文件

利用IFeatureWorkspace接口的CreateFeatureClass方法创建界址点Shape文件需要5个参数：

目录：利用IWorkspace接口 的PathName属性获取宗地图层的路径。

文件名：”888888JZD”

类型：esriGeometryPoint

空间参考：利用ISpatialReference接口获取宗地图层的空间参考

字段清单：准备好的文本文件，文件内容如下：

每一行数据分别是：序号、字段名、字段类型、字段长度、字段精度（小数位数）。

3.加载Shape文件

利用IMxDocument接口的IMaps的AddLayer方法加载新建的界址点图层。

4.创建界址点要素

利用IFeatureCursor接口的Insertfeature方法创建界址点要素 。

附：相关代码

主程序是《创建界址点要素图层》

其中用到 2 个函数：表名打开图层、距离

               5 个过程：CreateShapeFile、加载Shape文件、开始编辑、停止编辑、AddFeature

Option Explicit
Public pMxDocument As IMxDocument
'6426 个宗地，包含 714403 个节点,筛选出 390994 个界址点,行运 26 分钟。
Public Sub 创建界址点要素图层()
Dim 宗地表  As IFeatureClass, 宗地表名 As String
Dim 界址点表  As IFeatureClass, 界址点表名 As String
Dim 宗地号  As String
Dim 目录 As String, 字段清单 As String
Dim Shape类型 As Integer, i As Integer
Dim str As String
On Error Resume Next
字段清单 = "E:\ArcGIS\JZD字段.txt"
宗地表名 = "340523SYQZD"
界址点表名 = "340523JZD"

'打开宗地图层和宗地数据表
Set 宗地表 = 表名打开图层(宗地表名)

'获取要素类的文件路径
Dim pGeoDataset As IGeoDataset   '管理地理要素集
Set pGeoDataset = 宗地表
Dim pDataSet As IDataset       '数据
Set pDataSet = 宗地表
Dim pWorkspace As IWorkspace
Set pWorkspace = pDataSet.workspace
目录 = pWorkspace.PathName

'获取宗地表的外框坐标
Dim T As Date
T = Now
'Debug.Print Now

Dim pExtent As IEnvelope   '矩形
Set pExtent = pGeoDataset.Extent

Dim Xmax As Double, Ymax As Double
Dim Xmin As Double, Ymin As Double
Xmax = pExtent.Xmax: Xmax = Int(Xmax / 1000)
Ymax = pExtent.Ymax: Ymax = Int(Ymax / 1000)
Xmin = pExtent.Xmin: Xmin = Int(Xmin / 1000)
Ymin = pExtent.Ymin: Ymin = Int(Ymin / 1000)

'创建切片区域
Dim pts() As Collection  '点的集合
Dim 切片序号 As New Collection, 切片数量 As Integer
Dim N As Integer
Dim X As Double, Y As Double
Dim m As String
切片数量 = 0
For X = Xmin To Xmax
    For Y = Ymin To Ymax
        切片数量 = 切片数量 + 1
        m = Trim(X) + "/" + Trim(Y)
        切片序号.Add Item:=切片数量, Key:=m
    Next
Next
'Debug.Print "切片数量=", 切片数量, Now

'初始化切片区域
ReDim pts(切片数量)
For i = 1 To 切片数量
    Set pts(i) = New Collection
Next

'收集界址点坐标，创建界址点要素
Dim pQueryFilter As IQueryFilter
Dim pTableSort As ITableSort
Set pTableSort = New TableSort
Set pQueryFilter = New queryFilter
Dim 面游标 As ICursor        '游标
Set 面游标 = Nothing
    
With pTableSort                          '设置排序条件
     .Fields = "BDCDYH"                  '排序主键（字段）
     .Ascending("BDCDYH") = True         '上升排序
     .CaseSensitive("BDCDYH") = True     '区分大小写
     Set .queryFilter = pQueryFilter     '设置排序结果记录集
     Set .Table = 宗地表                 '设置排序表（原有记录集（表））
End With
    
pTableSort.Sort Nothing
Set 面游标 = pTableSort.Rows            '排序结果=pTableSort的所有行
If (面游标 Is Nothing) Then
    MsgBox ("排序未完成！")    '只是对记录集进行了排序，排序后，可以按了顺序操作每一个记录，并没有对图层表进行排序。
    Exit Sub
End If

Dim pGeoCol As IGeometryCollection     'polygon 的 Rings
Dim pPath As IPath                     'Rings 的 Path（组成面域的路线）
Dim pPoint As IPoint                   'Path 的 Point（组成路线的点）
Dim pGeometry      As IGeometry        '图形属性  通过pFeature.Shape获得 Geometry
Dim pPolygon         As IPolygon       '面对象
Dim pPointCol1     As IPointCollection '点的集合
Dim 环数 As Integer, 点数 As Integer
Dim 统编号 As Long, 顺序号 As Integer, 记录编号 As Long

Dim pt(0 To 4) As Variant
Dim Rpt As Variant

统编号 = 0
Dim 面记录 As IFeature
Set 面记录 = 面游标.NextRow
Do While Not 面记录 Is Nothing
    顺序号 = 1
    宗地号 = Left(面记录.Value(6), 19)
    Set pPolygon = 面记录.Shape
    Set pGeoCol = pPolygon                               '获取 polygon 的 Rings
    For 环数 = 0 To pGeoCol.GeometryCount - 1            '历遍 polygon 中的 rings （多重面域中的单个面域）
         If TypeOf pGeoCol.geometry(环数) Is IPath Then
             Set pPath = pGeoCol.geometry(环数)          '获取 Rings 的 Path（组成面域的路线）
             Set pPointCol1 = pPath                      '获取 Path 的 Points（组成路线的点的集合）
             For 点数 = 0 To pPointCol1.PointCount - 2
                 Set pPoint = pPointCol1.point(点数)     '获取 Points 的 Point（点集合中的点）
                     pPoint.QueryCoords X, Y             '获取点的坐标
                 m = Trim(Int(X / 1000)) + "/" + Trim(Int(Y / 1000))
                 N = 切片序号.Item(m)
                 i = 1
                 For Each Rpt In pts(N)
                     Rpt = pts(N)(i)
                     If 距离(X, Y, 0, Rpt(0), Rpt(1), 0) < 0.0001 Then
                         str = Rpt(4)
                         If InStr(str, 宗地号) < 1 Then
                             Rpt(4) = str + "\" + 宗地号      '追加宗地号
                             pts(N).Remove i                  '删除原有元素
                             pts(N).Add Rpt                   '添加 追加了宗地号 的新原元素
                         End If
                         GoTo 100
                     End If
                     i = i + 1
                 Next
                 pt(0) = X
                 pt(1) = Y
                 pt(2) = 顺序号
                 pt(3) = 统编号
                 pt(4) = 宗地号
                 pts(N).Add pt
                 
                 顺序号 = 顺序号 + 1
                 统编号 = 统编号 + 1
100:
             Next
         End If
    Next
    Set 面记录 = 面游标.NextRow
Loop

'把所有切片区域中的点转为按统编号排序的数组
ReDim NewPt(统编号 - 1, 3) As Variant
For N = 1 To 切片数量
    For i = 1 To pts(N).Count
        Rpt = pts(N)(i)
        NewPt(Rpt(3), 0) = Rpt(0)
        NewPt(Rpt(3), 1) = Rpt(1)
        NewPt(Rpt(3), 2) = Rpt(2)
        NewPt(Rpt(3), 3) = Rpt(4)
    Next
Next

'Open "D:\切片数量.txt" For Output As #1
'For i = 0 To 统编号 - 1
'    Write #1, NewPt(i, 0), NewPt(i, 1), NewPt(i, 2), NewPt(i, 3)
'Next
'Close
'Debug.Print "数据切片结束：", Now

'获取要素层的空间参考
Dim pSpatialReference As ISpatialReference
Set pSpatialReference = pGeoDataset.spatialReference

'创建界址点的Shape图层
If Dir(目录, 16) = "" Then MkDir 目录
If Dir(目录 & "\" & 界址点表名 & ".shp") <> "" Then GoTo 50

If Dir(字段清单) = "" Then
    MsgBox ("字段清单文件不存在")
    Exit Sub
End If

'创建Shape文件
Shape类型 = esriGeometryPoint     'esriGeometryPolyline
Call CreateShapeFile(目录, 界址点表名, Shape类型, pSpatialReference, 字段清单)

50: Call 加载Shape文件(目录, 界址点表名)

Set 界址点表 = 表名打开图层(界址点表名)

If 宗地表 Is Nothing Or 界址点表 Is Nothing Then
    MsgBox ("没有可操作的记录集:")
    Exit Sub
End If

Call 开始编辑(界址点表)
For i = 0 To 统编号 - 1
    X = NewPt(i, 0)
    Y = NewPt(i, 1)
    Dim 属性表(11) As Variant
    属性表(2) = i + 1              '2,标设码,      "BSM",1,9,9
    属性表(3) = NewPt(i, 3)        '3,宗地代码,    "ZDZHDM",4,19,0
    属性表(4) = "3001070000"       '4,要素代码,    "YSDM",4,10,0
    属性表(5) = Trim(i + 1)        '5,界址点号,    "JZDH",4,10,0
    属性表(6) = NewPt(i, 2)        '6,界址点顺序号,"SXH",1,9,9
    属性表(7) = "4"                '7,界标类型,    "JBLX",4,2,0
    属性表(8) = "2"                '8,界址点类型,  "JZDLX",4,2,0
    属性表(9) = Y                  '9,X坐标,       "XZBZ",3,16,15
    属性表(10) = X                 '10,Y坐标,       "YZBZ",3,16,15
    属性表(11) = 0                 '11,Z坐标,       "ZZBZ",3,16,15
                 
    Set pPoint = New point
    pPoint.PutCoords X, Y
    记录编号 = AddFeature(界址点表, pPoint, 属性表)
Next
Call 停止编辑(界址点表)
'Debug.Print "开始时间：", T
'Debug.Print "结束时间：", Now
'Debug.Print "使用时间：", DateDiff("n", T, Now)
MsgBox "生成界址点数:" + Trim(统编号) + Chr(10) _
       + "使用时间:" + DateDiff("n", T, Now) + " 分钟。"
Exit Sub
   
ErrorHandler:
MsgBox Err.Description
End Sub

Public Function 表名打开图层(Bname As String) As IFeatureClass    '打开操作表  '打开操作表(图层的属性集，可进行字段的删除、添加、查询行规操作)
    Dim pFeatureLayer           As IFeatureLayer
    Dim pFeatureClass           As IFeatureClass
    Dim i As Long
On Error Resume Next
    Set 表名打开图层 = Nothing
    Set pMxDocument = ThisDocument
    For i = 0 To pMxDocument.FocusMap.LayerCount - 1
        Set pFeatureLayer = pMxDocument.FocusMap.Layer(i)   '图层
        If pFeatureLayer.name = Bname Then
            Set 表名打开图层 = pFeatureLayer.FeatureClass
            Exit For
        End If
    Next
End Function

Sub CreateShapeFile(目录 As String, 文件名 As String, Shape类型 As Integer, 空间参考 As ISpatialReference, 字段清单 As String)
On Error Resume Next
目录 = TextBox1.text
If Dir(目录, 16) = "" Then MkDir 目录

文件名 = TextBox2.text       '不要加Shp后缀
If Dir(目录 & "\" & 文件名 & ".shp") <> "" Then
    MsgBox ("文件已经存在")
    Exit Sub
End If

字段清单 = TextBox3.text
If Dir(字段清单) = "" Then
    MsgBox ("字段清单文件不存在")
    Exit Sub
End If

' 打开用来放置ShapeFile文件的目录的工作空间（WorkSpace）
Dim pFWs As IFeatureWorkspace
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFWs = pWorkspaceFactory.OpenFromFile(目录, 0)

' 设置一个简单的字段集合对象
Dim pFields As IFields
Dim pFieldsEdit As IFieldsEdit
Set pFields = New Fields
Set pFieldsEdit = pFields
Dim pField As IField
Dim pFieldEdit As IFieldEdit

'创建 FID 和 Shape 字段，它需要一个Geometry定义和空间引用对象
Set pField = New Field
Set pFieldEdit = pField
pFieldEdit.name = "Shape"
pFieldEdit.Type = esriFieldTypeGeometry

'定义Geometry属性和
Dim pGeomDef As IGeometryDef
Dim pGeomDefEdit As IGeometryDefEdit

Set pGeomDef = New GeometryDef
Set pGeomDefEdit = pGeomDef
With pGeomDefEdit
    .GeometryType = Shape类型                       '几何定义
    Set .spatialReference = 空间参考                '空间参考（坐标投影）
End With
Set pFieldEdit.GeometryDef = pGeomDef
pFieldsEdit.AddField pField

'读入文件创建其它字段
Dim N As Integer, 字段名 As String, 类型 As Integer, 长度 As Integer, 小数位 As Integer
Close
Open 字段清单 For Input As #1
While Not (EOF(1))
    Input #1, N, 字段名, 类型, 长度, 小数位
        Set pField = New Field
        Set pFieldEdit = pField
        With pFieldEdit
            .name = 字段名
            .Type = 类型
            Select Case 类型
                   Case 3                    '双精度
                       .Scale = 小数位           '字段的小数位（精度）
                       .Precision = 长度         '字段的长度
                   Case 4                    '字符串
                       .Length = 长度            '字段的长度
            End Select
        End With
        pFieldsEdit.AddField pField
Wend
Close
 
'创建Shape文件，一些用于GeoDatabase的可选参数可以设置为Nothing
Dim pFeatClass As IFeatureClass
Set pFeatClass = pFWs.CreateFeatureClass(文件名, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
If Dir(目录 & "\" & 文件名 & ".shp") = "" Then
    MsgBox ("没有完成创建" + Err.Description)
Else
    MsgBox ("创建成功！")

End If
End Sub


Sub 加载Shape文件(sFilePath As String, sFileName As String)   'sFilePath = "E:\ArcGIS\统一坐标"  sFileName = "340523SYQZD"
Dim sDir As String
On Error Resume Next
sDir = Dir(sFilePath & "\" & sFileName & ".shp")
If (sDir = "") Then
    sDir = Dir(sFilePath & "\" & sFileName)
    If (sDir = "") Then
        MsgBox ("文件不存在")
        Exit Sub
    End If
End If

'定义并创建一个新的工作空间(ShapefileWorkspaceFactory)
Dim pWorkspaceFactory       As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
'打开一个 shapefile 文件夹
Dim pFeatureWorkspace       As IFeatureWorkspace
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0)

'创建新的要素图层并为其分配形状文件
Dim pFeatureLayer           As IFeatureLayer
Set pFeatureLayer = New FeatureLayer
Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(sFileName)
pFeatureLayer.name = pFeatureLayer.FeatureClass.AliasName

'将要素图层添加到当前地图
Dim pMxDocument             As IMxDocument
Set pMxDocument = Application.Document
    pMxDocument.FocusMap.AddLayer pFeatureLayer
End Sub

Sub 停止编辑(pFeatureClass As IFeatureClass)
Dim pDataSet As IDataset
Dim pWorkspaceEdit As IWorkspaceEdit
Set pDataSet = pFeatureClass
Set pWorkspaceEdit = pDataSet.workspace
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True
End Sub

Sub 开始编辑(pFeatureClass As IFeatureClass)
Dim pDataSet As IDataset
Dim pWorkspaceEdit As IWorkspaceEdit
Set pDataSet = pFeatureClass
Set pWorkspaceEdit = pDataSet.workspace
pWorkspaceEdit.StartEditOperation   '开始编辑
pWorkspaceEdit.StartEditing True
End Sub

'添加实体对象到地图图层
'要素类已打开,并在 开始编辑 状态
'返回记录编号
Function AddFeature(pFeatureClass As IFeatureClass, pGeometry As IGeometry, 属性表() As Variant) As Long
'定义并初始化缓冲区,属性字段赋值
Dim pFeatureBuffer As IFeatureBuffer
Set pFeatureBuffer = pFeatureClass.CreateFeatureBuffer()   '创建一个feature缓冲区，并返回IFeatureBuffer接口,用于储存新要素
Dim i As Integer
For i = 2 To UBound(属性表)
    pFeatureBuffer.Value(i) = 属性表(i)
Next

'定义并初始化插入游标
Dim pFtCursor As IFeatureCursor
Set pFtCursor = pFeatureClass.Insert(True)              '插入新的实体对象
Set pFeatureBuffer.Shape = pGeometry                    '向缓存游标的几何属性赋值 可以是IPolygon，IPolyline，IPoint, ILine
Dim 记录编号 As Long
    记录编号 = pFtCursor.Insertfeature(pFeatureBuffer)  '在插入游标处插入缓冲区对象
pFtCursor.Flush                                         '插入游标刷新，保存新记录
AddFeature = 记录编号
End Function

Function 距离(ByVal X1 As Double, ByVal y1 As Double, ByVal z1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal z2 As Double) As Double
  距离 = Sqr((X1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)
End Function