2024年7月25日17:18:58
'2024年7月25日17:18:23
Public 图层名 As String
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public 记录编号
Dim KZW1A As Byte
Public FUZU As String
Public kzw20 As Byte ''20控制位，只有定义byte型才能只占一个字节
Public asciibyte As Byte
Public JJ As Integer
Public kk As Long
Public onechar() As String
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long, Dbf指针2 As Long, Dbf指针3 As Long 'Dbf文件名、文件号、指针
Public mm As String
Public N As Long, i As Integer, r As Integer
Public fType(0) As Integer, fData(0) '选择集过滤条件
Public fType1(0) As Integer, fData1(0) As Variant
Public SelectA As AcadSelectionSet '选择集
Public Entry As AcadEntity 'CAD实体
Public XDType As Variant, xData As Variant '查询扩展属性
Public longN As Long
Public version As Byte
Public dateF(2) As Byte
'Dim 表名 As String
Public 发包方编码 As String
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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")
DoEvents
Next
20: 线Points = ShpPoints
End Function
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)
DoEvents
Next i
Shp多边形面积 = -1 * 面积 / 2
End Function
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
DoEvents
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
DoEvents
Next
End If
面Points = ShpPoints
End Function
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_CM_114E",
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",500000.0], '加常数
Dim 中央径线 As String 'PARAMETER["Central_Meridian",114.0], '中央子午线
Dim 常数 As Long
中央径线 = "PARAMETER[" & Chr(34) & "Central_Meridian" & Chr(34) & Chr(44) & Format(中央子午线, "0.0") + "]" & Chr(44)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节字节按位进行位与运算
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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") '保留3位小数
图形框(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))
'记录头 大端序《记录条数，记录长度》
'For i = 1 To 记录条数此处应有个循环，循环记录头（从1开始的记录编号和记录长度）
记录编号 = 记录编号 + 1
Put #ShpFile, Shp指针, 转为大端序(记录编号) '记录编号 此处第101个字节应为记录号1开始，而不是条数
记录指针 = Shp指针 + 4 '图形输出结束后补，1个字段的记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
'fType1(0) = 0: fData1(0) = "*Polyline"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
'Select Case Entry.ObjectName
' Case "AcDbHatch"
' Dim MyHatch As AcadSelectionSet
' Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
'
' MyHatch.Select acSelectionSetAll, , , fType1, fData1
' 环数 = 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指针 + 点数 * 16
' DoEvents
' Next
' Put #ShpFile, 环指针, 点序 '补写总点数
'
' Case "AcDb2dPolyline", "AcDbPolyline", "AcDbLwPolyline", "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，子环坐标在points数组中位置从0开始
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数 * 16
'End Select
记录长度 = Shp指针 - 记录长度 - 8 '这里是shp的一条记录的记录长度
Put #ShpFile, 记录指针, 转为大端序(字段总长度) '当前一条记录的记录长度
Offset = 记录指针 - 5
'Offset = LOF(ShxFile) '文件长度
longN = 转为大端序(Offset / 2)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '写入偏移量
longN = 转为大端序(记录长度 / 2) '一个记录在主文件中的偏移量是字符的偏移量（字节数除以2）的，它表示从主文件开始至这个记录记录头第一个字节的字符个数。本博使用vba7，对应的是unicode编码，因此，1个字符=2个字节，主文件中的文件头位100个字节，因此第一个记录的偏移量是 100/2=50。
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '索引记录中存储的内容长度与主文件中记录头中存储的数值相同，即记录长度=字节长度/2。
记录长度 = Shp指针
kzw20 = &H20 '只占一个字节
Put #DbfFile, Dbf指针, kzw20 'dbf数据部分，&h20为控制位，转为10进制为32'不同记录条之间需要控制位20，不同字段不需要控制位20
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Dbf指针3 = Dbf指针
For JJ = 1 To pField(N).Length '首先输入19个（字段长度）控制位20切记从1开始，不能从0开始
Put #DbfFile, Dbf指针3, kzw20
Dbf指针3 = Dbf指针3 + 1
Next
FUZU = xData(N)
FUZU = Trim(FUZU) '字符串后面的空格去掉
Dbf指针2 = Dbf指针 '这句话一定要放在for外面
Put #DbfFile, Dbf指针2, FUZU 'Asc(Mid(FUZU, kk, 1))
' For kk = 1 To Len(FUZU)
' 'Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))''mid
'' asciibyte = Asc(Mid(FUZU, kk, 1)) 'asc（）函数返回的上一个四字节整数，内存中占4字节，因此需要放入byte中截取一个字节
'
' Put #DbfFile, Dbf指针2, Asc(Mid(FUZU, kk, 1)) ''Dbf指针2 + kk - 1，这句话返回一个整型数，而不是字节位置。midb函数返回字符串中的字节，而不是字符。此处有待完善代码，应为每个字符的ascii码
' 'MsgBox Asc(Mid(FUZU, kk, 1)) Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))
' Dbf指针2 = Dbf指针2 + 1
' Next
' '' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
'Stop
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
''本博vba采用的ansi编码模式，需生成一个内容为"ANSI"的.cpg文件,否则arcgis10.7默认采用utf-8编码读取文件会出现乱码
图层名 = "JZD" '改为待转数据的图层名称
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open FileName:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
ShpName = 表名 & ".shp": ShpFile = 1
ShxName = 表名 & ".shx": ShxFile = 2
DbfName = 表名 & ".dbf": DbfFile = 3
CPGName = 表名 & ".CPG": CPGFile = 4
'如果文件已存在，删除文件
If Dir(ShpName) <> "" Then Kill ShpName
If Dir(ShxName) <> "" Then Kill ShxName
If Dir(DbfName) <> "" Then Kill DbfName
If Dir(CPGName) <> "" Then Kill CPGName
'创建打开Shape文件,输出头文件内容
Open CPGName For Binary As #CPGFile '打开文件
Put #CPGFile, 1, "ANSI"
Close
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 * 32 'pdf的文件头32字节和字段描述，每个字段32字节
On Error Resume Next
For N = 1 To 11 '只有11个字节 记录字段名，是ASCII码值，如果字段名超过11个字符会被舍去。
If N <= Len(pField(i).Name) Then 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
文件头长度 = 字段数 * 32 + 32 + 1
Put #DbfFile, 9, 文件头长度 '文件头长度 文件头32+每个字段32+控制位0D一个字节
Put #DbfFile, 11, 字段总长度 + 1 '一条记录的字节长度
version = 3
Put #DbfFile, 1, version 'dbf版本信息
dateF(0) = 2024 - 1900: dateF(1) = 2: dateF(2) = 26
Put #DbfFile, 2, dateF '最近的更新日期,年数是1900到今年的年数
Dim myb As Byte
myb = &HD
Put #DbfFile, 文件头长度, myb '0d控制位，vba中&h为十六进制数，c++中是0X
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code，文件号9994
Put #ShxFile, 1, longN
longN = 1000 '小端序，系统默认一样不需要转
Put #ShpFile, 29, longN '1 版本号
Put #ShxFile, 29, longN
longN = MySheet.Cells(4, 2) '点线面135类型，此代码为面转换代码
Put #ShpFile, 33, longN '33 几何类型
Put #ShxFile, 33, longN
'以下输出图形信息
范围框(0) = 100000000: 范围框(1) = 100000000 ' 生成shp的范围框，x小 y小
范围框(2) = 0: 范围框(3) = 0 ' 生成shp的范围框，x大 y大，初始化
Shp指针 = 101: 记录长度 = 101
Shx指针 = 101
记录条数 = 0
Dbf指针 = 文件头长度 + 1
r = LOF(DbfFile)
Set SelectA = creatsel("mysel")
' fType(0) = MySheet.Cells(2, 1): fData(0) = MySheet.Cells(2, 3)
' fType(1) = MySheet.Cells(3, 1): fData(1) = MySheet.Cells(3, 3)
fType(0) = 0: fData(0) = "*Polyline"
SelectA.Select acSelectionSetAll, , , fType, fData
' SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "SOUTH", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
If Not IsEmpty(xData) Then
记录条数 = 记录条数 + 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
pField(i).Name = xData(pField(i).Number)
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
Call Shape面记录内容(Entry)
DoEvents
Else
End If
Next
SelectA.Delete
'关闭Shape文件
Dim Offset As Long
N = 记录条数 / 2
Put #DbfFile, 5, N
KZW1A = &H1A '控制位1A
Put #DbfFile, Dbf指针, KZW1A
Offset = LOF(ShpFile) / 2 '这里的长度是字节数/2
longN = 转为大端序(Offset)
Put #ShpFile, 25, longN 'Shp文件长度
longN = 转为大端序((Shx指针 - 1) / 2)
Put #ShxFile, 25, longN 'Shx文件长度字节数/2
' Put #ShpFile, 37, 图形框
' Put #ShxFile, 37, 图形框
Put #ShpFile, 37, 范围框
Put #ShxFile, 37, 范围框
Close
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成", , "QQ443440204"
End Sub
24年*************
**************
*************************
'2024年3月4日21:40:53
Public 图层名 As String
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public 记录编号
Dim KZW1A As Byte
Public FUZU As String
Public kzw20 As Byte ''20控制位，只有定义byte型才能只占一个字节
Public asciibyte As Byte
Public JJ As Integer
Public kk As Long
Public onechar() As String
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long, Dbf指针2 As Long, Dbf指针3 As Long 'Dbf文件名、文件号、指针
Public mm As String
Public N As Long, i As Integer, r As Integer
Public fType(1) As Integer, fData(1) '选择集过滤条件
Public fType1(0) As Integer, fData1(0) As Variant
Public SelectA As AcadSelectionSet '选择集
Public Entry As AcadEntity 'CAD实体
Public XDType As Variant, xData As Variant '查询扩展属性
Public longN As Long
Public version As Byte
Public dateF(2) As Byte
'Dim 表名 As String
Public 发包方编码 As String
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节字节按位进行位与运算
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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") '保留3位小数
图形框(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))
'记录头 大端序《记录条数，记录长度》
'For i = 1 To 记录条数此处应有个循环，循环记录头（从1开始的记录编号和记录长度）
记录编号 = 记录编号 + 1
Put #ShpFile, Shp指针, 转为大端序(记录编号) '记录编号 此处第101个字节应为记录号1开始，而不是条数
记录指针 = Shp指针 + 4 '图形输出结束后补，1个字段的记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
Next
Put #ShpFile, 环指针, 点序 '补写总点数
Case "AcDb2dPolyline", "AcDbPolyline", "AcDbLwPolyline", "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，子环坐标在points数组中位置从0开始
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8 '这里是shp的一条记录的记录长度
Put #ShpFile, 记录指针, 转为大端序(字段总长度) '当前一条记录的记录长度
Offset = 记录指针 - 5
'Offset = LOF(ShxFile) '文件长度
longN = 转为大端序(Offset / 2)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '写入偏移量
longN = 转为大端序(记录长度 / 2) '一个记录在主文件中的偏移量是字符的偏移量（字节数除以2）的，它表示从主文件开始至这个记录记录头第一个字节的字符个数。本博使用vba7，对应的是unicode编码，因此，1个字符=2个字节，主文件中的文件头位100个字节，因此第一个记录的偏移量是 100/2=50。
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '索引记录中存储的内容长度与主文件中记录头中存储的数值相同，即记录长度=字节长度/2。
记录长度 = Shp指针
kzw20 = &H20 '只占一个字节
Put #DbfFile, Dbf指针, kzw20 'dbf数据部分，&h20为控制位，转为10进制为32'不同记录条之间需要控制位20，不同字段不需要控制位20
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Dbf指针3 = Dbf指针
For JJ = 1 To pField(N).Length '首先输入19个（字段长度）控制位20切记从1开始，不能从0开始
Put #DbfFile, Dbf指针3, kzw20
Dbf指针3 = Dbf指针3 + 1
Next
FUZU = xData(2 * N + 1)
FUZU = Trim(FUZU) '字符串后面的空格去掉
Dbf指针2 = Dbf指针 '这句话一定要放在for外面
Put #DbfFile, Dbf指针2, FUZU 'Asc(Mid(FUZU, kk, 1))
' For kk = 1 To Len(FUZU)
' 'Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))''mid
'' asciibyte = Asc(Mid(FUZU, kk, 1)) 'asc（）函数返回的上一个四字节整数，内存中占4字节，因此需要放入byte中截取一个字节
'
' Put #DbfFile, Dbf指针2, Asc(Mid(FUZU, kk, 1)) ''Dbf指针2 + kk - 1，这句话返回一个整型数，而不是字节位置。midb函数返回字符串中的字节，而不是字符。此处有待完善代码，应为每个字符的ascii码
' 'MsgBox Asc(Mid(FUZU, kk, 1)) Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))
' Dbf指针2 = Dbf指针2 + 1
' Next
' '' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
'Stop
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
''本博vba采用的ansi编码模式，需生成一个内容为"ANSI"的.cpg文件,否则arcgis10.7默认采用utf-8编码读取文件会出现乱码
图层名 = "JZD" '改为待转数据的图层名称
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open filename:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
ShpName = 表名 & ".shp": ShpFile = 1
ShxName = 表名 & ".shx": ShxFile = 2
DbfName = 表名 & ".dbf": DbfFile = 3
CPGName = 表名 & ".CPG": CPGFile = 4
'如果文件已存在，删除文件
If Dir(ShpName) <> "" Then Kill ShpName
If Dir(ShxName) <> "" Then Kill ShxName
If Dir(DbfName) <> "" Then Kill DbfName
If Dir(CPGName) <> "" Then Kill CPGName
'创建打开Shape文件,输出头文件内容
Open CPGName For Binary As #CPGFile '打开文件
Put #CPGFile, 1, "ANSI"
Close
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 * 32 'pdf的文件头32字节和字段描述，每个字段32字节
On Error Resume Next
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
文件头长度 = 字段数 * 32 + 32 + 1
Put #DbfFile, 9, 文件头长度 '文件头长度 文件头32+每个字段32+控制位0D一个字节
Put #DbfFile, 11, 字段总长度 + 1 '一条记录的字节长度
version = 3
Put #DbfFile, 1, version 'dbf版本信息
dateF(0) = 2024 - 1900: dateF(1) = 2: dateF(2) = 26
Put #DbfFile, 2, dateF '最近的更新日期,年数是1900到今年的年数
Dim myb As Byte
myb = &HD
Put #DbfFile, 文件头长度, myb '0d控制位，vba中&h为十六进制数，c++中是0X
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code，文件号9994
Put #ShxFile, 1, longN
longN = 1000 '小端序，系统默认一样不需要转
Put #ShpFile, 29, longN '1 版本号
Put #ShxFile, 29, longN
longN = MySheet.Cells(4, 2) '点线面135类型，此代码为面转换代码
Put #ShpFile, 33, longN '33 几何类型
Put #ShxFile, 33, longN
'以下输出图形信息
范围框(0) = 100000000: 范围框(1) = 100000000 ' 生成shp的范围框，x小 y小
范围框(2) = 0: 范围框(3) = 0 ' 生成shp的范围框，x大 y大，初始化
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
' SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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
KZW1A = &H1A '控制位1A
Put #DbfFile, Dbf指针, KZW1A
Offset = LOF(ShpFile) / 2 '这里的长度是字节数/2
longN = 转为大端序(Offset)
Put #ShpFile, 25, longN 'Shp文件长度
longN = 转为大端序((Shx指针 - 1) / 2)
Put #ShxFile, 25, longN 'Shx文件长度字节数/2
' Put #ShpFile, 37, 图形框
' Put #ShxFile, 37, 图形框
Put #ShpFile, 37, 范围框
Put #ShxFile, 37, 范围框
Close
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成", , "QQ443440204"
End Sub
2024年2月24日00:57:40
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public 记录编号
Dim KZW1A As Byte
Public FUZU As String
Public kzw20 As Byte ''20控制位，只有定义byte型才能只占一个字节
Public asciibyte As Byte
Public JJ As Integer
Public kk As Long
Public onechar() As String
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long, Dbf指针2 As Long, Dbf指针3 As Long 'Dbf文件名、文件号、指针
Public mm As String
Public N As Long, i As Integer, r As Integer
Public fType(1) As Integer, fData(1) '选择集过滤条件
Public SelectA As AcadSelectionSet '选择集
Public Entry As AcadEntity 'CAD实体
Public XDType As Variant, xData As Variant '查询扩展属性
Public longN As Long
Public version As Byte
Public dateF(2) As Byte
'Dim 表名 As String
Public 发包方编码 As String
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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))
'记录头 大端序《记录条数，记录长度》
'For i = 1 To 记录条数此处应有个循环，循环记录头（从1开始的记录编号和记录长度）
记录编号 = 记录编号 + 1
Put #ShpFile, Shp指针, 转为大端序(记录编号) '记录编号 此处第101个字节应为记录号1，而不是条数
记录指针 = Shp指针 + 4 '图形输出结束后补输出记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
Dim fType1(0) As Integer, fData1(0) As Variant
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
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，子环坐标在points数组中位置从0开始
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8 '这里是shx的记录长度，此处待了解逻辑关系
Put #ShpFile, 记录指针, 转为大端序(字段总长度) '当前一条记录的记录长度
Offset = 记录指针 - 5
'Offset = LOF(ShxFile) '文件长度
longN = 转为大端序(Offset / 2)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '写入偏移量
longN = 转为大端序(记录长度 / 2) '一个记录在主文件中的偏移量是字符的偏移量（字节数除以2）的，它表示从主文件开始至这个记录记录头第一个字节的字符个数。本博使用vba7，对应的是unicode编码，因此，1个字符=2个字节，主文件中的文件头位100个字节，因此第一个记录的偏移量是 100/2=50。
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '索引记录中存储的内容长度与主文件中记录头中存储的数值相同，即记录长度=字节长度/2。
记录长度 = Shp指针
kzw20 = &H20 '只占一个字节
Put #DbfFile, Dbf指针, kzw20 'dbf数据部分，&h20为控制位，转为10进制为32'不同记录条之间需要控制位20，不同字段不需要控制位20
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Dbf指针3 = Dbf指针
For JJ = 1 To pField(N).Length '首先输入19个（字段长度）控制位20切记从1开始，不能从0开始
Put #DbfFile, Dbf指针3, kzw20
Dbf指针3 = Dbf指针3 + 1
Next
FUZU = xData(2 * N + 1)
FUZU = Trim(FUZU) '字符串后面的空格去掉
Dbf指针2 = Dbf指针 '这句话一定要放在for外面
For kk = 1 To Len(FUZU)
'Put #DbfFile, r + N, Asc(Mid(pField(i).Name, N, 1))''mid
asciibyte = Asc(Mid(FUZU, kk, 1)) 'asc（）函数返回的上一个四字节整数，内存中占4字节，因此需要放入byte中截取一个字节
Put #DbfFile, Dbf指针2, asciibyte ''Dbf指针2 + kk - 1，这句话返回一个整型数，而不是字节位置。midb函数返回字符串中的字节，而不是字符。此处有待完善代码，应为每个字符的ascii码
'MsgBox Asc(Mid(FUZU, kk, 1))
Dbf指针2 = Dbf指针2 + 1
Next
'' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
'Stop
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, 12)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open filename:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
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 * 32
On Error Resume Next
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
文件头长度 = 字段数 * 32 + 32 + 1
Put #DbfFile, 9, 文件头长度 '文件头长度
Put #DbfFile, 11, 字段总长度 + 1 '一条记录的字节长度
version = 3
Put #DbfFile, 1, version '版本信息
dateF(0) = 24: dateF(1) = 2: dateF(2) = 20
Put #DbfFile, 2, dateF '最近的更新日期
Dim myb As Byte
myb = &HD
Put #DbfFile, 文件头长度, myb '0d倒序转10进制218103808，2字节倒序，非4字节函数（13）十六进制
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code
Put #ShxFile, 1, longN
longN = 1000 '经读取arcgis10.7版本shp发现这个是小端序，不需要转 1000转16进制3E8倒序E8030000转10进制，百度是3892510720(VBA -402456576 )
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
SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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
KZW1A = &H1A '控制位1A
Put #DbfFile, Dbf指针, KZW1A
Offset = LOF(ShpFile)
longN = 转为大端序(Offset)
Put #ShpFile, 25, longN 'Shp文件长度
longN = 转为大端序(Shx指针 - 1)
Put #ShxFile, 25, longN 'Shx文件长度
Put #ShpFile, 37, 图形框
Put #ShxFile, 37, 图形框
' Put #ShpFile, 37, 范围框
' Put #ShxFile, 37, 范围框
Close
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成"
End Sub
2024年2月23日18:43:12
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public 记录编号
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long 'Dbf文件名、文件号、指针
Public mm As String
Public N As Long, i As Integer, r As Integer
Public fType(1) As Integer, fData(1) '选择集过滤条件
Public SelectA As AcadSelectionSet '选择集
Public Entry As AcadEntity 'CAD实体
Public XDType As Variant, xData As Variant '查询扩展属性
Public longN As Long
Public version As Byte
Public dateF(2) As Byte
'Dim 表名 As String
Public 发包方编码 As String
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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))
'记录头 大端序《记录条数，记录长度》
'For i = 1 To 记录条数此处应有个循环，循环记录头（从1开始的记录编号和记录长度）
记录编号 = 记录编号 + 1
Put #ShpFile, Shp指针, 转为大端序(记录编号) '记录编号 此处第101个字节应为记录号1，而不是条数
记录指针 = Shp指针 + 4 '图形输出结束后补输出记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
Dim fType1(0) As Integer, fData1(0) As Variant
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
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，子环坐标在points数组中位置从0开始
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8 '这里是shx的记录长度，此处待了解逻辑关系
Put #ShpFile, 记录指针, 转为大端序(字段总长度) '当前一条记录的记录长度
Offset = 记录指针 - 5
'Offset = LOF(ShxFile) '文件长度
longN = 转为大端序(Offset / 2)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '写入偏移量
longN = 转为大端序(记录长度 / 2) '一个记录在主文件中的偏移量是字符的偏移量（字节数除以2）的，它表示从主文件开始至这个记录记录头第一个字节的字符个数。本博使用vba7，对应的是unicode编码，因此，1个字符=2个字节，主文件中的文件头位100个字节，因此第一个记录的偏移量是 100/2=50。
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4 '索引记录中存储的内容长度与主文件中记录头中存储的数值相同，即记录长度=字节长度/2。
记录长度 = Shp指针
Put #DbfFile, Dbf指针, 32 'dbf数据部分，&h20为控制位，转为10进制为32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, xData(2 * N + 1) ''此处有待完善代码，应为每个字符的ascii码
'' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
' Stop
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, 12)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open filename:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
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 * 32
On Error Resume Next
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
文件头长度 = 字段数 * 32 + 32 + 1
Put #DbfFile, 9, 文件头长度 '文件头长度
Put #DbfFile, 11, 字段总长度 + 1 '一条记录的字节长度
version = 3
Put #DbfFile, 1, version '版本信息
dateF(0) = 24: dateF(1) = 2: dateF(2) = 20
Put #DbfFile, 2, dateF '最近的更新日期
Dim myb As Byte
myb = &HD
Put #DbfFile, 文件头长度, myb '0d倒序转10进制218103808，2字节倒序，非4字节函数（13）十六进制1A倒序1A000000转10进制436207616
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code
Put #ShxFile, 1, longN
longN = 1000 '经读取arcgis10.7版本shp发现这个是小端序，不需要转 1000转16进制3E8倒序E8030000转10进制，百度是3892510720(VBA -402456576 )
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
SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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, 图形框
' Put #ShpFile, 37, 范围框
' Put #ShxFile, 37, 范围框
Close
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成"
End Sub
2024年2月22日21:46:10
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public 记录编号
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long 'Dbf文件名、文件号、指针
Public mm As String
Public N As Long, i As Integer, r As Integer
Public fType(1) As Integer, fData(1) '选择集过滤条件
Public SelectA As AcadSelectionSet '选择集
Public Entry As AcadEntity 'CAD实体
Public XDType As Integer, xData As Variant '查询扩展属性
Public longN As Long
Public version As Byte
Public dateF(2) As Byte
'Dim 表名 As String
Public 发包方编码 As String
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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大
Dim 图形框(3), 范围框(3)
图形框(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))
'记录头 大端序《记录条数，记录长度》
'For i = 1 To 记录条数此处应有个循环，循环记录头（从1开始的记录编号和记录长度）
记录编号 = 1
Put #ShpFile, Shp指针, 转为大端序(记录编号) '记录编号 此处第101个字节应为记录号1，而不是条数
记录指针 = Shp指针 + 4 '图形输出结束后补输出记录长度
Shp指针 = Shp指针 + 8
'记录内容
Put #ShpFile, Shp指针, 5 '记录类型
Shp指针 = Shp指针 + 4
Put #ShpFile, Shp指针, 图形框: Shp指针 = Shp指针 + 32 '图形边界合：x小、y小、大、y大
Dim fType1(0) As Integer, fData1(0) As Variant
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
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，子环坐标在points数组中位置从0开始
Put #ShpFile, Shp指针, ShpPoints: Shp指针 = Shp指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8
Put #ShpFile, 记录指针, 转为大端序(记录长度) '当前记录要素的记录长度
Offset = 记录指针 - 5
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
记录长度 = Shp指针
Put #DbfFile, Dbf指针, 32 'dbf数据部分，&h20为控制位，转为10进制为32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, xData(2 * N + 1) ''此处有待完善代码，应为数据内容
'' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, 12)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open filename:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
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 * 32
On Error Resume Next
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 '版本信息
dateF(0) = 24: dateF(1) = 2: dateF(2) = 20
Put #DbfFile, 2, dateF '最近的更新日期
Dim myb As Byte
myb = &HD
Put #DbfFile, 文件头长度, myb '0d倒序转10进制218103808，2字节倒序，非4字节函数（13）十六进制1A倒序1A000000转10进制436207616
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code
Put #ShxFile, 1, longN
longN = 1000 '经读取arcgis10.7版本shp发现这个是小端序，不需要转 1000转16进制3E8倒序E8030000转10进制，百度是3892510720(VBA -402456576 )
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
SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成"
End Sub
Public 字段总长度 As Integer
Public 文件头长度 As Integer
Public 记录条数 As Long
Public 记录长度 As Long
Public 范围框(0 To 3) As Double
Public 图形框(0 To 3) As Double
Public XDType As Variant, xData As Variant '查询扩展属性
Public ShpName As String, ShpFile As Integer, Shp指针 As Long 'Shp文件名、文件号、指针
Public ShxName As String, ShxFile As Integer, Shx指针 As Long
Public mm As String
Public N As Long, i As Integer, r As Integer
Public 控制位20 As Byte, 间隔符0D As Byte
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long 'Dbf文件名、文件号、指针
Public 表名 As String, 字段数 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
Public pField() As 字段属性 '字段组
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 创建一个4字节的数组，用于存储结果的每个字节
Dim byteToBigEndianBytes() As Byte
Dim bytes(3) As Byte
' 将value的每个字节分别赋给数组，从大端序到小端序
bytes(0) = value And &HFF ' 最低字节
bytes(1) = (value And &HFF00) \ &H100 ' 次低字节
bytes(2) = (value And &HFF0000) \ &H100 ' 次高字节
bytes(3) = (value And &HFF000000) \ &H1000000 ' 最高字节
' 返回大端序字节数组
Dim mys As String
Dim i As Integer
For i = LBound(bytes) To UBound(bytes)
mys = mys & Right("00" & Hex(bytes(i)), 2)
Next i
转为大端序 = Val("&h" & mys)
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大
Dim 图形框(3), 范围框(3)
图形框(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大
Dim fType1(0) As Integer, fData1(0) As Variant
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
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指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8
Put #ShpFile, 记录指针, 转为大端序(记录长度) '当前记录要素的记录长度
Offset = 记录指针 - 5
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
记录长度 = Shp指针
控制位20 = &H20
Put #DbfFile, Dbf指针, onebyte 'dbf数据部分，&h20为控制位,占一个字节，整型数据默认4个字节，转为10进制为32
Dbf指针 = Dbf指针 + 1
For N = 0 To 字段数 - 1
Put #DbfFile, Dbf指针, xData(2 * N + 1) ''此处有待完善代码，应为数据内容
'' Put #DbfFile, Dbf指针, pField(N).Name ''此处有待完善代码，应为数据内容
Dbf指针 = Dbf指针 + pField(N).Length
Next
End Sub
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
Dim fType(1) As Integer, fData(1) '选择集过滤条件
Dim SelectA As AcadSelectionSet '选择集
Dim Entry As AcadEntity 'CAD实体
Dim longN As Long
Dim version As Byte 'dbf 文件头，版本信息1个字节
Dim dateF(2) As Byte '最近更新日期，3个字节
'Dim 表名 As String
Dim 发包方编码 As String
On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, 12)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open FileName:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
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 * 32
On Error Resume Next
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, 文件头长度 '文件头长度,占2个字节（int 2字节，long 4字节）
Put #DbfFile, 11, 字段总长度 '一条记录的字节长度
' Dim version As Byte
version = 3
Put #DbfFile, 1, version '版本信息
dateF(0) = 24: dateF(1) = 2: dateF(2) = 21
Put #DbfFile, 2, dateF '最近的更新日期
间隔符0D = &HD
Put #DbfFile, 文件头长度, 间隔符0D '
longN = 170328064 '' 9994转16进制270A倒序0A270000转十进制170328064
Put #ShpFile, 1, longN '1 File Code
Put #ShxFile, 1, longN
longN = 1000 '经读取arcgis10.7版本shp发现这个是小端序，不需要转 1000转16进制3E8倒序E8030000转10进制，百度是3892510720(VBA -402456576 )
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
SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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)'shx与shp文件头一致，此处待完善
Put #ShxFile, 25, longN 'Shx文件长度
Put #ShpFile, 37, 范围框
Put #ShxFile, 37, 范围框
Close
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成"
End Sub
240216—21：43
Public 坐标系 As String, 加带号 As Boolean, 中央子午线 As Double, 投影带宽 As Integer
Public DbfName As String, DbfFile As Integer, Dbf指针 As Long 'Dbf文件名、文件号、指针
Public 表名 As String
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
Public pField() As 字段属性
'整理多段线的节点坐标
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 Function
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
'整理多段线的坐标数组，调整节点的方向：外环为顺时针、内环为逆时针；取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
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)
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
投影项目 = 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],"
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]]" '长度单位(米)
Dim PrjName As String
PrjName = 表名 & ".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 Function
Function 转为大端序(ByVal value As Long) As Long
' 将 Long 类型的值拆分为 4 个 Byte
Dim byte1 As Long, byte2 As Long, byte3 As Long, byte4 As Long
byte1 = value Mod 256 ' 最低有效字节
value = value \ 256 ' 移除最低有效字节
byte2 = value Mod 256 ' 次低有效字节
value = value \ 256
byte3 = value Mod 256 ' 次高有效字节
value = value \ 256
byte4 = value ' 最高有效字节
' 交换字节顺序以从大端序排列
Dim temp As Long
temp = byte1
byte1 = byte4
byte4 = temp
temp = byte2
byte2 = byte3
byte3 = temp
转为大端序 = byte4 * &H100000 + byte3 * &H1000 + byte2 * &H10 + byte1
' 将交换后的字节重新组合为 Long 类型的值
End Function
'Shx文件名、文件号、指针
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大
Dim 图形框(3), 范围框(3)
图形框(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大
Dim fType1(0) As Integer, fData1(0) As Variant
fType1(0) = 0: fData1(0) = "*Polyline,Region,Hatch,circle"
'Select Case Entry.ObjectName '此处代码有待完善
' Case "AcDbHatch"
' Dim MyHatch As New Collection
' Set MyHatch = 填充图案的环PR(Entry)
' 环数 = MyHatch.Count
Select Case Entry.ObjectName
Case "AcDbHatch"
Dim MyHatch As AcadSelectionSet
Set MyHatch = ThisDrawing.SelectionSets.Add("myh")
MyHatch.Select acSelectionSetAll, , , fType1, fData1
环数 = 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指针 + 点数 * 16
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指针 + 点数 * 16
End Select
记录长度 = Shp指针 - 记录长度 - 8
Put #ShpFile, 记录指针, 转为大端序(记录长度) '当前记录要素的记录长度
Offset = 记录指针 - 5
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
记录长度 = Shp指针
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
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
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(20)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
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
ShpPoints = 线Points(Plobj) '获取多段线的节点坐标
线数 = 1
点数 = (UBound(ShpPoints) + 1) / 2
记录长度 = 44 + 线数 * 4 + 点数 * 16
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 + 点数 * 16
'记录内容
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指针 + 点数 * 16
longN = 转为大端序(Offset)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
longN = 转为大端序(记录长度)
Put #ShxFile, Shx指针, longN: Shx指针 = Shx指针 + 4
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
Public Function creatsel(ByVal selname As String) As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
Set sel = ThisDrawing.SelectionSets.Item(i)
If StrComp(sel.Name, selname, 1) = 0 Then
sel.Delete
Exit For
End If
Next i
Set creatsel = ThisDrawing.SelectionSets.Add(selname)
End Function
Sub dwg动态属性转Shapefile()
''Set sel = creatsel("mysel")
''sel.Select acSelectionSetAll
'MsgBox sel.Count
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
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 '查询扩展属性
Dim longN As Long
Dim version As Byte
Dim dateF(2) As Byte
'Dim 表名 As String
Dim 发包方编码 As String
'On Error Resume Next
' Start Excel
Set excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
On Error Resume Next
excel.Visible = True
Dim 工作目录 As String
ShpName = 表名 & ".shp"
工作目录 = ThisDrawing.Path & "\" 'ThisDrawing.Path + "\NEWShape\"
If InStr(工作目录, "C:\Program Files (x86)\AutoCAD 2008") > 0 Then Exit Sub
'创建空间参考文件
'定义空间参考.show '自定义选择参数 坐标系、加带号、中央子午线、投影带宽
坐标系 = "2000国家大地坐标系"
中央子午线 = 114
加带号 = False
投影带宽 = 3
Dim PrjName As String
PrjName = ThisDrawing.Path & "\ZD.prj"
Dim m(0 To 12) As String
常数 = 中央子午线 / 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") & "]"
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]]" '长度单位
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
发包方编码 = Left(ThisDrawing.Name, 12)
Dim 转换标准 As String 'Shape转换标准样本.xlsx
转换标准 = ThisDrawing.Path & "\ZD.xlsx"
excel.Workbooks.Open FileName:=转换标准 '打开文件
'Dim MySheet As excel.worksheet 'Excel工作表
'For Each MySheet In excel.ActiveWorkbook.Sheets '历遍Excel的工作表
' If excel.activesheet.Name = "JZX" Or MySheet.Name = "说明" Then Exit For '目前不转界址线
Dim MySheet As Object
' Set MySheet = excel.worksheets(1)
Set MySheet = excel.activesheet
表名 = 工作目录 & 发包方编码 & MySheet.Name
文件名 = 表名 + ".prj"
FileCopy PrjName, 文件名 '复制预先创建好的空间参考文件
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 * 32
On Error Resume Next
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 '版本信息
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
SelectA.Highlight (True)
For Each Entry In SelectA
Entry.GetXData "", XDType, xData
' MsgBox Entry.ObjectName
' ThisDrawing.Regen acActiveViewport
记录条数 = 记录条数 + 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
'excel.ActiveWorkbook.Close SaveChanges:=True
MsgBox "已完成"
End Sub
扫一扫
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
