AutoCAD VBA 输出Shapefile文件
发布时间
阅读量：
阅读量
江苏省地质测绘院姜法明
该系统集成了地图创建、空间分析以及基于地图的应用程序开发等多种功能模块。该格式因其广泛支持而成为主流选择；然而由于其特有的属性，开放获取的标准使得不同软件之间能够无缝衔接；文件大小较小且读取性能优异，在数据处理效率上有显著优势。
ArcGIS用于保存空间数据及其属性信息。
这种标准格式通常由多个相关子文件组成。
这种标准格式通常由多个相关子文件组成。
一种基于形状数据的标准地理信息系统产品包含以下几个关键组成部分：
包括形状数据层(.shp)作为主要的数据载体；
空间索引层(.shx)作为快速定位多边形特征的基础；
属性表层(.dbf)作为与每个区域相关的详细信息存储位置；
以及投影信息记录层(.prj)作为地理数据集的空间参考系统记录。
如图所示的一个以‘宗地’名为单位构建的Shapefile项目中，则包含了四个必要的组成部分：
包括形状数据层(.shp)作为主要的数据载体；
空间索引层(.shx)作为快速定位多边形特征的基础；
属性表层(.dbf)作为与每个区域相关的详细信息存储位置；
以及投影信息记录层(.prj)作为地理数据集的空间参考系统记录。
| 文件 | 分类 | 记录内容 |
|---|---|---|
| .shp | 主文件 | 图形要素的几何信息 |
| .shx | 索引文件 | 图形要素在.shp文件中的记录位置及长度 |
| .dbf | 属性表 | 图形要素的属性列表 |
| .prj | 空间参考 | 坐标系、投影方法、椭球信息、中央子午线等 |
Shapefile图形格式 (.shp)
Shapefile格式的核心文件承载了地理基准数据信息。该核心文件包含有固定长度的数据头部以及可变数量的数据字段部分。每一个可变长度的数据字段部分都包括有单独的数据段标识符以及相应的属性值区域。
1.1文件头
主文件头共计17个字段共计100字符编码长度其中包括九个小端或大端的32位有符号整数类型紧接着之后是八个小端或大端的64位双精度浮点型
| 记录位置 | 类型（长度） | 字节序 | 说明 | 实例数据 |
|---|---|---|---|---|
| 1 | Integer(4) | 大端序 | 文件的更新信息（定值=19988） | 19988 |
| 5 | 空 | |||
| 25 | Integer(4) | 大端序 | 文件的字节数 | LOF(ShpFile) |
| 29 | Integer(4) | 大端序 | 文件的版本号（定值=1000） | 1000 |
| 33 | Integer(4) | 小端序 | 文件记录类型 | 1（1-点、3-线、5-面） |
| 37 | Double(32) | 小端序 | Shapefile中所有图形的外接矩形 | minx,minY,manX,manY |
| 69 | Double(16) | 小端序 | Z坐标的最小值和最大值（可空） | minZ,ManY |
| 85 | Double(16) | 小端序 | M坐标的最小值和最大值（可空） | minM，manM |
其中：
文件中的字节数应于完成所有图形输出后进行填写；头文件中的所有内容都应最终填写。
Shapefile中所有图形的外接矩形，可以在所有图形输出完成后补写。
文件的更新信息：ArcGIS10.1以前的版本就9994，以后的版本是19988。
1.2图形数据
图形数据包含记录头和记录内容二部分，长度根据记录类型和形状确定。
1.2.1点要素的输出内容
设:已有图形数据的总长度=i
| 记录分类 | 输出位置 | 输出内容 | 类型 | 字节序 | 说明 |
|---|---|---|---|---|---|
| 记录头 8个字节 | 101+i | 记录编号 | Integer | 大端序 | 从1开始 |
| 105+i | 记录长度 | Integer | 大端序 | 点的记录长度=20 | |
| 记录数据 20个字节 | 109+i | 记录类型 | Integer | 小端序 | 点的记录类型=1 |
| 113+i | X,Y | Double | 小端序 |
1.2.2线要素的输出内容
设:已有图形数据的总长度=i；线数=xi,点数=N
| 记录分类 | 输出位置 | 输出内容 | 类型 | 字节序 | 说明 |
|---|---|---|---|---|---|
| 记录头 8个字节 | 101+i | 记录编号 | Integer | 大端序 | 从1开始 |
| 105+i | 记录长度 | Integer | 大端序 | 44+线数4+点数16 | |
| 记录数据 | 109+i | 记录类型 | Integer | 小端序 | 线的记录类型=3 |
| 113+i | BoxPoints | Double | 小端序 | 图形边界合：x小、y小、x大、y大 | |
| 145+i | 线数 | Integer | 小端序 | ||
| 149+i | 总点数 | Integer | 小端序 | ||
| 153+i | 点序1 | Integer | 小端序 | 线1的0号点在总点数中的序号 | |
| 157+i | Points1 | Double | 小端序 | 坐标数组 | |
| …… | 小端序 | ||||
| …… | 小端序 | ||||
| 点序n | Integer | 小端序 | 线n的0号点在总点数中的序号 | ||
| Pointsn | Double | 小端序 | 坐标数组 |
其中大多数情况：线数=1、点序=0
记录长度=4（记录类型）+32（图形边界合）+4（线数）+4（总点数）+xi4(点序)+N16(坐标X、Y)
1.2.3面要素的输出内容
设:已有图形数据的总长度=i；环数=qi,点数=N
| 记录分类 | 输出位置 | 输出内容 | 类型 | 字节序 | 说明 |
|---|---|---|---|---|---|
| 记录头 8个字节 | 101+i | 记录编号 | Integer | 大端序 | 从1开始 |
| 105+i | 记录长度 | Integer | 大端序 | 44+线数4+点数16 | |
| 记录数据 | 109+i | 记录类型 | Integer | 小端序 | 面的记录类型=5 |
| 113+i | BoxPoints | Double | 小端序 | 图形边界合：x小、y小、x大、y大 | |
| 145+i | 环数 | Integer | 小端序 | ||
| 149+i | 总点数 | Integer | 小端序 | ||
| 153+i | 点序1 | Integer | 小端序 | 环1的0号点在总点数中的序号，从0开始 | |
| 157+i | Points1 | Double | 小端序 | 坐标数组 | |
| …… | 小端序 | ||||
| …… | 小端序 | ||||
| 点序n | Integer | 小端序 | 环n的0号点在总点数中的序号 | ||
| Pointsn | Double | 小端序 | 坐标数组 |
其中：
1.封闭多段线表示的面 环数=1、环序=0；
2.填充图案表示的面（弧岛）外环的坐标应是顺时针，还必须回到第一点；
3.内环的坐标应是逆时针，也必须回到第一点。
记录长度=4（记录类型）+32（图形边界合）+4（环数）+4（总点数）+qi4(点序)+N16(坐标X、Y)
1.2.4记录长度和开始位置
| 数据类型 | 简码 | 记录长度 |
|---|---|---|
| 整型 | Integer | 4 |
| 单精度 | Single | 8 |
| 双精度 | Double | 8 |
| 字符串 | String | 8 |
| 日期 | Date | 8 |
| 逻辑 | Blob | 1 |
每一个要素输出后，文件的字节数=LOF(ShpFile)；
第一个要素的开始位置=101（100为头文件）；
以后每一个要素的开始位置= LOF(ShpFile)+1。
1.3字节序
小端序是正常的数。
大端序是将数字由十进制转换为十六进制，并将每个两位的十六进制数值逆序排列后转换回十进制形式。例如：
19988 转为十六进制 270A 倒序 0A270000 用十进制来表示 170328064
1000 转为十六进制 1F4 倒序 F4010000 用十进制来表示 -201261056
- Shapefile索引文件（.shx）
索引文件(.Shx)中，其中前100个字节构成文件头；其内容与数据文件(.shp)相同，并且在输出数据文件时可以同时处理。
索引文件的图形信息只有二项：开始位置、记录长度
| 记录项 | 数值 | 数据类型 | 字节序 |
|---|---|---|---|
| 开始位置 | 对应记录在shp文件中的记录位置 | Integer | 大端序 |
| 记录长度 | 在shp文件中的记录长度 | Integer | 大端序 |
3. Shapefile属性文件（. dbf）
在进行CAD导出Shape文件的过程中
为满足将Shape文件转换的需求而设计并制作了一个配置文档。该Excel文档被定义为主要的数据存储格式。每一个工作表对应于一个输出绘图层，在这些层中包含了选择集筛选条件设置、形状文件格式类型设置、字段数量设定、字段长度限制以及字段列表生成的相关参数说明。如图所示：
第一行是转出Shape文件的文件名=ZD；
第二行CAD选择集过滤器为：8 地块 （表示 图层=地块）；
其过滤器设置为：0 Polyline,Region,Hatch （其中类型包括多段线、面域和填充图案）
第四行是文件的要素类型；
第五行是字段数量（不包括Shp自动生成的Shape字段和ID字段 ;
第六行是字段的总长度；
第八行开始是字段清单。
其中：
第一列是字段名，字段名不支持中文，并且最多只能有11个字符。
第二列属于字段类型字段，并表示该字段对应类型代码的ASCII码值。根据Shape框架的规定，在此字段中应输入该字段类型的代码值。下表列举了几种常见类型的取值范围及对应示例：
| 字段类型 | 类型代码 | ASCII****码值 | ArcGIS****取值 |
|---|---|---|---|
| 整型 | I | 73 | esriFieldTypeInteger |
| 单精度 | S | 83 | esriFieldTypeSingle |
| 双精度 | N | 78 | esriFieldTypeDouble |
| 字符串 | C | 67 | esriFieldTypeString |
| 日期 | D | 68 | esriFieldTypeDate |
| 逻辑 | B | 66 | esriFieldTypeBlob |
***ArcGIS10.2不支持逻辑型字段
第三列是字段长度；
第四列是字段精度（小数的位数，只有双精度类型的字段需要）
第六列是取值方法，有：编号、扩展属性、黙认值、X坐标、Y坐标、Z坐标六个选项。
编号：按输出顺序自动编号获取
扩展属性：提取输出图形扩展属性第i项的值，i= 第七列中的数字
黙认值：第七列中的数据
X坐标：点要素的插入点坐标、面要素的中心点坐标的X值
Y坐标：点要素的插入点坐标、面要素的中心点坐标的Y值
Z坐标：点要素的插入点坐标、面要素的中心点坐标的Y值
4. Shapefile空间参考（.prj）
shp格式的空间参考文件即为地图投影信息；
同样也可以通过复制类似项目的Projection文件来进行编辑组合；
并且可以根据四个关键参数——坐标系统、中央子午线值、投影范围宽度以及横坐标的有无编号标志——进行设置以完成编辑组合。
PROJCS["Xian_1980_3_Degree_GK_CM_117E",
GEOGCS["GCS_Xian_1980",
DATUM["D_Xian_1980",
SPHEROID["Xian_1980",6378140.0,298.257]],
PRIMEM["Greenwich",0.0],
UNIT["Degree",0.0174532925199433]],
PROJECTION["Gauss_Kruger"],
PARAMETER["False_Easting",500000.0],
PARAMETER["False_Northing",0.0],
PARAMETER["Central_Meridian",117],
PARAMETER["Scale_Factor",1.0],
PARAMETER["Latitude_Of_Origin",0.0],
UNIT["Meter",1.0]]
5.核心源代码
5.1输出模块
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public Type 字段属性
Name As String '字段名
Type As Byte '字段类型
Length As Byte '字段长度
pScale As Byte '字段精度
Method As String '取值方法
Number As Integer '属性项序号
Value As Variant '黙认值
End Type
12. Dim pField() As 字段属性 '字段组
Dim 字段数 As Integer
Dim 字段总长度 As Integer
Dim 文件头长度 As Integer
Dim 记录条数 As Long
Dim 记录长度 As Long
Dim 范围框(0 To 3) As Double
Dim 图形框(0 To 3) As Double
Dim ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Dim ShxName As String, ShxFile As Integer, Shx指针 As Long 'Shx文件名、文件号、指针
Dim DbfName As String, DbfFile As Integer, Dbf指针 As Long 'Dbf文件名、文件号、指针
25. 26. Sub 创建空间参考文件()
创建空间参考.show
End Sub
30. 31. Sub 动态属性转Shape()
Dim mm As String
Dim N As Long, i As Integer, r As Integer
Dim fType(1) As Integer, fData(1) '选择集过滤条件
Dim SelectA As AcadSelectionSet '选择集
Dim Entry As AcadEntity 'CAD实体
Dim XDType As Variant, xData As Variant '查询扩展属性
39. Dim longN As Long
Dim version As Byte
Dim dateF(2) As Byte
Dim 表名 As String, 发包方编码 As String
On Error Resume Next
Dim 工作目录 As String
工作目录 = "E:\ArcGIS\NEWShape\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
Call 创建目录(工作目录)
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
52. 坐标系 = "1980西安坐标系"
中央子午线 = 118.5
加带号 = False
投影带宽 = 3
57. Dim PrjName As String
PrjName = 投影文件(坐标系, 加带号, 中央子午线, 投影带宽)
60. 发包方编码 = Left(ThisDrawing.Name, 12)
62. Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = VBApath & "Shape转换标准样本.xlsx"
Workbooks.Open FileName:=转换标准 '打开文件
66. Dim MySheet As Worksheet 'Excel工作表
For Each MySheet In ActiveWorkbook.Sheets '历遍Excel的工作表
If MySheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
73. ShpName = 表名 & ".shp": ShpFile = 1
ShxName = 表名 & ".shx": ShxFile = 2
DbfName = 表名 & ".dbf": DbfFile = 3
'如果文件已存在，删除文件
If Dir(ShpName) <> "" Then Kill ShpName
If Dir(ShxName) <> "" Then Kill ShxName
If Dir(DbfName) <> "" Then Kill DbfName
'创建打开Shape文件,输出头文件内容
Open ShpName For Binary As #ShpFile '打开文件
Open ShxName For Binary As #ShxFile '打开文件
Open DbfName For Binary As #DbfFile '打开文件
字段数 = MySheet.Cells(5, 2)
字段总长度 = MySheet.Cells(6, 2)
ReDim pField(字段数 - 1)
For i = 0 To 字段数 - 1
pField(i).Name = MySheet.Cells(i + 8, 1)
pField(i).Type = MySheet.Cells(i + 8, 2)
pField(i).Length = MySheet.Cells(i + 8, 3)
pField(i).pScale = MySheet.Cells(i + 8, 4)
pField(i).Method = MySheet.Cells(i + 8, 6)
Select Case pField(i).Method '取值方法
Case "扩展属性"
pField(i).Number = MySheet.Cells(i + 8, 7)
Case "黙认值"
pField(i).Value = MySheet.Cells(i + 8, 7)
End Select
r = 32 + i
For N = 1 To 11 '只有11个字节 记录字段名，是ASCII码值，如果字段名超过11个字符会被舍去。
Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))
Next
Put #DbfFile, r + 12, pField(i).Type
Put #DbfFile, r + 17, pField(i).Length
Put #DbfFile, r + 18, pField(i).pScale
Next
字段总长度 = 字段总长度 + 1
文件头长度 = 字段数 * 32 + 32 + 1
Put #DbfFile, 9, 文件头长度 '文件头长度
Put #DbfFile, 11, 字段总长度 '一条记录的字节长度
version = 3
Put #DbfFile, 1, version '版本信息
117. dateF(0) = 19: dateF(1) = 2: dateF(2) = 15
Put #DbfFile, 2, dateF '最近的更新日期
Put #DbfFile, 文件头长度, 13 '结束标志
longN = 170328064
Put #ShpFile, 1, longN '1 File Code
Put #ShxFile, 1, longN
longN = 1000
Put #ShpFile, 29, longN '1 版本号
Put #ShxFile, 29, longN
longN = MySheet.Cells(4, 2)
Put #ShpFile, 33, longN '33 几何类型
Put #ShxFile, 33, longN
'以下输出图形信息
范围框(0) = 100000000: 范围框(1) = 100000000
范围框(2) = 0: 范围框(3) = 0
Shp指针 = 101: 记录长度 = 101
Shx指针 = 101
记录条数 = 0
Dbf指针 = 文件头长度 + 1
r = LOF(DbfFile)
ThisDrawing.SelectionSets.Item("窗选").Delete
Err.Clear
Set SelectA = ThisDrawing.SelectionSets.Add("窗选")
fType(0) = MySheet.Cells(2, 1): fData(0) = MySheet.Cells(2, 3)
fType(1) = MySheet.Cells(3, 1): fData(1) = MySheet.Cells(3, 3)
SelectA.Select acSelectionSetAll, , , fType, fData
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
记录条数 = 记录条数 + 2
For i = 0 To 字段数 - 1
Select Case pField(i).Method '取值方法
Case "扩展属性"
pField(i).Name = xData(pField(i).Number)
Case "黙认值"
pField(i).Name = pField(i).Value
Case "编号"
pField(i).Name = 记录条数 / 2
Case Else
pField(i).Name = ""
End Select
Next
Select Case MySheet.Cells(4, 2) 'Shape类型
Case 5 '面
Call Shape面记录内容(Entry)
Case 3 '线
Call Shape线记录内容(Entry)
Case 1 '点
Call Shape点记录内容(Entry)
End Select
Next
SelectA.Delete
'关闭Shape文件
Dim Offset As Long
N = 记录条数 / 2
Put #DbfFile, 5, N
Offset = LOF(ShpFile)
longN = 转为大端序(Offset)
Put #ShpFile, 25, longN 'Shp文件长度
longN = 转为大端序(Shx指针 - 1)
Put #ShxFile, 25, longN 'Shx文件长度
Put #ShpFile, 37, 范围框
Put #ShxFile, 37, 范围框
Close
Next
Workbooks("Shape转换标准样本").Close
End Sub
187. '整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取4位小数（ArcMap中只接收4位小数）
Public Function 面Points(Plobj As AcadEntity, 环序 As Long, R点数 As Long) As Double()
Dim Mxy As Variant
Dim 方向 As Integer, 坐标序 As Integer
Dim ShpPoints() As Double
On Error Resume Next
方向 = Sgn(Shp多边形面积(Plobj)) '负号函数
坐标序 = IIf(环序 = 1, 方向, -1 * 方向)
Dim i As Integer, J As Integer, r As Integer, N As Integer
r = IIf(Plobj.ObjectName = "AcDbPolyline", 2, 3)
Mxy = Plobj.Coordinates
N = Int(UBound(Mxy) / r) '原编号从0开始的点数
R点数 = N + 2 '编号从1开始,回到第一点的点数
ReDim ShpPoints(N * 2 + 3) '编号从0开始,回到第一点的坐标个数
If 坐标序 = 1 Then '正向
J = 0
For i = 0 To N
ShpPoints(J) = Format(Mxy(i * r), "0.0000")
ShpPoints(J + 1) = Format(Mxy(i * r + 1), "0.0000")
J = J + 2
Next
ShpPoints(J) = Format(Mxy(0), "0.0000")
ShpPoints(J + 1) = Format(Mxy(1), "0.0000")
Else '反向
ShpPoints(0) = Format(Mxy(0), "0.0000")
ShpPoints(1) = Format(Mxy(1), "0.0000")
J = 2
For i = N To 0 Step -1
ShpPoints(J) = Format(Mxy(i * r), "0.0000")
ShpPoints(J + 1) = Format(Mxy(i * r + 1), "0.0000")
J = J + 2
Next
End If
面Points = ShpPoints
End Function
Sub Shape面记录内容(Entry As AcadEntity)
Dim longP As Long
Dim Obj小 As Variant, Obj大 As Variant
Dim 环指针 As Long, 环数 As Long, 环序 As Long
Dim 点数 As Long, 点序 As Long
Dim 记录指针 As Long
Dim Offset As Long, longN As Long
Dim loopObj As AcadEntity
Dim N As Integer
Dim ShpPoints() As Double
On Error Resume Next
Entry.GetBoundingBox Obj小, Obj大
图形框(0) = Format(Obj小(0), "0.000")
图形框(1) = Format(Obj小(1), "0.000")
图形框(2) = Format(Obj大(0), "0.000")
图形框(3) = Format(Obj大(1), "0.000")
范围框(0) = IIf(图形框(0) < 范围框(0), 图形框(0), 范围框(0))
范围框(1) = IIf(图形框(1) < 范围框(1), 图形框(1), 范围框(1))
范围框(2) = IIf(图形框(2) > 范围框(2), 图形框(2), 范围框(2))
范围框(3) = IIf(图形框(3) > 范围框(3), 图形框(3), 范围框(3))
'记录头 大端序《记录条数，记录长度》
Put #ShpFile, Shp指针, 转为大端序(记录条数) '记录编号
记录指针 = Shp指针 + 4 '图形输出结束后补输出记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As New Collection
Set MyHatch = 填充图案的环PR(Entry)
环数 = MyHatch.Count
Put #ShpFile, Shp指针, 环数 '环数
'总点数在后面补写
环指针 = Shp指针 + 4
Shp指针 = Shp指针 + 环数 * 4 + 8
点数 = 0: 点序 = 0: 环序 = 1 '总点数、各环的起点编号
For Each loopObj In MyHatch
Put #ShpFile, 环指针 + 4 * 环序, 点序 '点序
ShpPoints = 面Points(loopObj, 环序, 点数) '获取多段线的坐标数组
点序 = 点序 + 点数
环序 = 环序 + 1
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数
Next
Put #ShpFile, 环指针, 点序 '补写总点数
Case "AcDb2dPolyline", "AcDbPolyline", "AcDbWlPolyline", "AcDb3dPolyline"
ShpPoints = 面Points(Entry, 1, 点数) '获取多段线的坐标数组
Put #ShpFile, Shp指针, 1: Shp指针 = Shp指针 + 4 '环数=1
Put #ShpFile, Shp指针, 点数: Shp指针 = Shp指针 + 4 '总点数
Put #ShpFile, Shp指针, 0: Shp指针 = Shp指针 + 4 '环序=0
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数
End Select
记录长度 = Shp指针 - 记录长度 - 8
Put #ShpFile, 记录指针, 转为大端序(记录长度) '当前记录要素的记录长度
281. Offset = 记录指针 - 5
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
记录长度 = Shp指针
289. Put #DbfFile, Dbf指针, 32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, pField(N).Name
Dbf指针 = Dbf指针 + pField(N).Length
Next
End Sub
297. Public Function Shp多边形面积(Plobj As AcadEntity) As Double '当面积为正值，多边形为顺时针；当面积为负值，多边形为逆时针。
Dim N As Long, i As Long, J As Long, r As Integer
Dim 面积 As Double
On Error Resume Next
xy = Plobj.Coordinates
r = IIf(Plobj.ObjectName = "AcDbPolyline", 2, 3)
N = Int(UBound(xy) / r)
For i = 0 To N
J = IIf(i = N, 0, i + 1)
面积 = 面积 + xy(i * r) * xy(J * r + 1) - xy(i * r + 1) * xy(J * r)
Next i
Shp多边形面积 = -1 * 面积 / 2
End Function
Sub Shape点记录内容(PointObj As AcadEntity)
Dim longP As Long, N As Integer
Dim Offset As Long, longN As Long
Dim xy As Variant
Dim ShpPoints(0 To 1) As Double
Select Case PointObj.ObjectName
Case "AcDbText"
xy = PointObj.InsertionPoint
Case "AcDbBlockReference"
xy = PointObj.InsertionPoint
Case "AcDbPoint"
xy = PointObj.Coordinates
Case "AcDbCircle"
xy = PointObj.Center
End Select
ShpPoints(0) = xy(0)
ShpPoints(1) = xy(1)
范围框(0) = IIf(ShpPoints(0) < 范围框(0), ShpPoints(0), 范围框(0))
范围框(1) = IIf(ShpPoints(1) < 范围框(1), ShpPoints(1), 范围框(1))
范围框(2) = IIf(ShpPoints(0) > 范围框(2), ShpPoints(0), 范围框(2))
范围框(3) = IIf(ShpPoints(1) > 范围框(3), ShpPoints(1), 范围框(3))
'记录头 大端序《记录条数，记录长度》
Offset = Shp指针 - 1
Put #ShpFile, Shp指针, 转为大端序(记录条数): Shp指针 = Shp指针 + 4 '记录条数
Put #ShpFile, Shp指针, 转为大端序(20): Shp指针 = Shp指针 + 4 '记录长度:点的记录长度固定=20
'记录内容
Put #ShpFile, Shp指针, 1: Shp指针 = Shp指针 + 4 '记录类型
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 16
341. longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
346. Put #DbfFile, Dbf指针, 32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, pField(N).Name
Dbf指针 = Dbf指针 + pField(N).Length
Next
End Sub
354. Sub Shape线记录内容(Plobj As AcadEntity)
Dim longP As Long, N As Integer
Dim Offset As Long, longN As Long
Dim 点数 As Long, 线数 As Long
Dim X As Double
Dim ShpPoints() As Double
Dim Obj小 As Variant, Obj大 As Variant
362. ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数
Plobj.GetBoundingBox Obj小, Obj大
图形框(0) = Format(Obj小(0), "0.000")
图形框(1) = Format(Obj小(1), "0.000")
图形框(2) = Format(Obj大(0), "0.000")
图形框(3) = Format(Obj大(1), "0.000")
范围框(0) = IIf(图形框(0) < 范围框(0), 图形框(0), 范围框(0))
范围框(1) = IIf(图形框(1) < 范围框(1), 图形框(1), 范围框(1))
范围框(2) = IIf(图形框(2) > 范围框(2), 图形框(2), 范围框(2))
范围框(3) = IIf(图形框(3) > 范围框(3), 图形框(3), 范围框(3))
'记录头 大端序《记录条数，记录长度》
Offset = Shp指针 - 1
Put #ShpFile, Shp指针, 转为大端序(记录条数): Shp指针 = Shp指针 + 4 '记录条数
Put #ShpFile, Shp指针, 转为大端序(记录长度): Shp指针 = Shp指针 + 4 '记录长度:线点的记录长度=52 + 线数 * 4 + 点数
'记录内容
Put #ShpFile, Shp指针, 3: Shp指针 = Shp指针 + 4 '记录类型
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '坐标范围（Box）
Put #ShpFile, Shp指针, 线数: Shp指针 = Shp指针 + 4 '线段的个数
Put #ShpFile, Shp指针, 点数: Shp指针 = Shp指针 + 4 '顶点个数
Put #ShpFile, Shp指针, 0: Shp指针 = Shp指针 + 4 '坐标点在Points的位置
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数
388. longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
393. Put #DbfFile, Dbf指针, 32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, pField(N).Name
Dbf指针 = Dbf指针 + pField(N).Length
Next
End Sub
401. '整理多段线的节点坐标
Public Function 线Points(Plobj As AcadEntity) As Double()
Dim xy As Variant
Dim i As Integer, J As Integer, r As Integer
Dim ShpPoints() As Double
Select Case Plobj.ObjectName
Case "AcDbPolyline"
xy = Plobj.Coordinates
r = 2
Case "AcDb2dPolyline"
xy = Plobj.Coordinates
r = 3
Case "AcDbLine"
ReDim ShpPoints(3)
xy = Plobj.StartPoint
ShpPoints(0) = xy(0)
ShpPoints(1) = xy(1)
xy = Plobj.EndPoint
ShpPoints(2) = xy(0)
ShpPoints(3) = xy(1)
GoTo 20
End Select
J = Int(UBound(xy) / r)
ReDim ShpPoints(J * 2 + 1)
For i = 0 To J
ShpPoints(i * 2) = Format(xy(i * r), "0.0000")
ShpPoints(i * 2 + 1) = Format(xy(i * r + 1), "0.0000")
Next
20: 线Points = ShpPoints
End Function5.2空间参考模块
Function 投影文件(坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer) As String
Dim str1 As String, str2 As String
Dim 投影项目 As String 'PROJCS["CGCS2000_3_Degree_GK_Zone_39",
Dim 地理标志 As String 'GEOGCS["GCS_China_Geodetic_Coordinate_System_2000",
Dim 基准 As String 'DATUM["D_China_2000",
Dim 球体 As String 'SPHEROID["CGCS2000",6378137.0,298.257222101]],
Dim 加常数 As String 'PARAMETER["False_Easting",39500000.0], '加常数
Dim 中央径线 As String 'PARAMETER["Central_Meridian",117.0], '中央子午线
Dim 常数 As Long
中央径线 = "PARAMETER[" & Chr(34) & "Central_Meridian" & Chr(34) & Chr(44) & Format(中央子午线, "0.0") + "]" & Chr(44)
Select Case 坐标系
Case "2000国家大地坐标系"
str1 = "PROJCS[" & Chr(34) & "CGCS2000_"
地理标志 = "GEOGCS[" & Chr(34) & "GCS_China_Geodetic_Coordinate_System_2000" & Chr(34) & Chr(44)
基准 = "DATUM[" & Chr(34) & "D_China_2000" & Chr(34) & Chr(44)
球体 = "SPHEROID[" & Chr(34) & "CGCS2000" & Chr(34) & ",6378137.0,298.257222101]],"
'"2000 国家大地坐标系", "CGCS2000", 6378137, 6356752.31414 '1/298.257222101
Case "1980西安坐标系"
str1 = "PROJCS[" & Chr(34) & "Xian_1980_"
地理标志 = "GEOGCS[" & Chr(34) & "GCS_Xian_1980" & Chr(34) & Chr(44)
基准 = "DATUM[" & Chr(34) & "D_Xian_1980" & Chr(34) & Chr(44)
球体 = "SPHEROID[" & Chr(34) & "Xian_1980" & Chr(34) & ",6378140.0,298.257]],"
'"1975年椭球", "XA1980",6378140, 6356755.2882 '298.257
Case "1954年北京坐标系"
str1 = "PROJCS[" & Chr(34) & "Beijing_1954_"
地理标志 = "GEOGCS[" & Chr(34) & "GCS_Beijing_1954" & Chr(34) & Chr(44)
基准 = "DATUM[" & Chr(34) & "D_Beijing_1954" & Chr(34) & Chr(44)
球体 = "SPHEROID[" & Chr(34) & "Beijing_1954" & Chr(34) & ",6378245.0,298.3]],"
'"克拉索夫斯基椭球", "BJ1954", 6378245, 6356863.0188 '298.3
Case "WGS_1984坐标系"
str1 = "PROJCS[" & Chr(34) & "WGS_1984_"
地理标志 = "GEOGCS[" & Chr(34) & "GCS_WGS_1984" & Chr(34) & Chr(44)
基准 = "DATUM[" & Chr(34) & "D_WGS_1984" & Chr(34) & Chr(44)
球体 = "SPHEROID[" & Chr(34) & "WGS_1984" & Chr(34) & ",6378137.0,298.257223563]],"
'"WGS84椭球", "WGS84", 6378137, 6356752.3142 '298.257223563
End Select
Select Case 投影带宽
Case 3
Select Case 加带号
Case True
常数 = 中央子午线 / 3
投影项目 = str1 + "3_Degree_GK_Zone_" + Trim(常数) & Chr(34) & Chr(44) '"Beijing_1954_3_Degree_GK_Zone_39" "Xian_1980_3_Degree_GK_Zone_39"
加常数 = "PARAMETER[" & Chr(34) & "False_Easting" & Chr(34) & Chr(44) & Format(常数 * 1000000 + 500000, "0.0") & "],"
Case False
投影项目 = str1 + "3_Degree_GK_CM_" + Trim(中央子午线) + "E" & Chr(34) & Chr(44) '"Beijing_1954_3_Degree_GK_CM_117E" "Xian_1980_3_Degree_GK_CM_117E"
加常数 = "PARAMETER[" & Chr(34) & "False_Easting" & Chr(34) & Chr(44) & "500000.0],"
End Select
Case 6
Select Case 加带号
Case True
常数 = 中央子午线 / 6
投影项目 = str1 + "GK_Zone_" + Trim(常数) & Chr(34) & Chr(44) '"Beijing_1954_GK_Zone_20" "CGCS2000_GK_Zone_20" "Xian_1980_GK_Zone_20"
加常数 = "PARAMETER[" & Chr(34) & "False_Easting" & Chr(34) & Chr(44) & Format(常数 * 1000000 + 500000, "0.0") & "],"
Case False
投影项目 = str1 + "GK_CM_" + Trim(中央子午线) + "E" & Chr(34) & Chr(44) '"CGCS2000_GK_CM_117E" "Xian_1980_GK_CM_117E"
加常数 = "PARAMETER[" & Chr(34) & "False_Easting" & Chr(34) & Chr(44) & "500000.0],"
End Select
End Select
Dim m(0 To 12) As String
m(0) = 投影项目
m(1) = 地理标志
m(2) = 基准
m(3) = 球体
m(4) = "PRIMEM[" & Chr(34) & "Greenwich" & Chr(34) & ",0.0]," '径线起点 格林威治"
m(5) = "UNIT[" & Chr(34) & "Degree" & Chr(34) & ",0.0174532925199433]]," '弧度单位
m(6) = "PROJECTION[" & Chr(34) & "Gauss_Kruger" & Chr(34) & "]," '投影
m(7) = 加常数
m(8) = "PARAMETER[" & Chr(34) & "False_Northing" & Chr(34) & ",0.0]," '北纬
m(9) = 中央径线
m(10) = "PARAMETER[" & Chr(34) & "Scale_Factor" & Chr(34) & ",1.0]," '长度比例
m(11) = "PARAMETER[" & Chr(34) & "Latitude_Of_Origin" & Chr(34) & ",0.0]," '纬度起点
m(12) = "UNIT[" & Chr(34) & "Meter" & Chr(34) & ",1.0]]" '长度单位(米)
80. Dim PrjName As String
PrjName = VBApath + "空间参考.prj"
Open PrjName For Output As #1
Print #1, m(0) + m(1) + m(2) + m(3) + m(4) + m(5) + m(6) + m(7) + m(8) + m(9) + m(10) + m(11) + m(12)
Close
投影文件 = PrjName
End Function5.3窗体
Private Sub CommandButton1_Click()
坐标系 = ComboBox1.Text
中央子午线 = TextBox1.Value
加带号 = CheckBox1.Value
Unload Me
End Sub
Private Sub OptionButton1_Click()
投影带宽 = 3
End Sub
Private Sub OptionButton2_Click()
投影带宽 = 6
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem "2000国家大地坐标系"
ComboBox1.AddItem "1980西安坐标系"
ComboBox1.AddItem "1954年北京坐标系"
ComboBox1.AddItem "WGS_1984坐标系"
ComboBox1.ListIndex = 0
投影带宽 = 3
加带号 = True
End Sub
'其中：CGCS2000_3_Degree_GK_Zone_38 4526 '横坐标前加带号
'CGCS2000_3_Degree_GK_Zone_39 4527 '横坐标前加带号
'CGCS2000_3_Degree_GK_Zone_40 4528 '横坐标前加带号
'CGCS2000_GK_CM_117E 4509 '横坐标前不加带号
'CGCS2000_GK_CM_123E 4510 '横坐标前不加带号目录
1.1文件头
1.2图形数据
1.2.1点要素的输出内容
1.2.2线要素的输出内容
1.2.3面要素的输出内容
1.2.4记录长度和开始位置
1.3字节序
3. Shapefile属性文件（. dbf）
4. Shapefile空间参考（.prj）
5.核心源代码
5.1输出模块
5.2空间参考模块
5.3窗体
全部评论 (0)
还没有任何评论哟~