剖面测量是较常见的工程测量项目,早期剖面测量采用的经纬仪导线放线,测量地形变换点的高程,现在使用 GPS放线测量地形变换点的高程,极大地提高了效率。 但把高程点展到CAD图上后,如何快速高效地把图上的高程数据转换成剖面数据,一直没有合式的方法,这里介绍一个自动输出剖面数据的程序。
- 已有数据
1.1中心线是一条完整的轻便多段线(LWPolyline),两端与首尾桩号的剖面定位线相交。如下图中的红色线。
1.2 剖面定位线是直线(line)或二个点的轻便多段线(LWPolyline),你面向上游,定位线从左画到右,每条定位线应与中心线相交。如上图中的黑色线
1.3剖面名称(桩号)是文本注记(Text),插入点应在定位线与中心线交点的3m之内.
1.4高程点可以是属性块(INSERT),也可以是文本注记(Text),最好是属性块,插入点在定位线的2m范围内。
2、输出剖面数据的格式
2.1 本程序的格式
本程序输出的剖面数据格式为纵横剖面合一数轴格式,其中纵剖面只有与横剖面定位线相交处的高程。如:
K0+0,42.05,42.00
-7.66,43.75,-5.80,42.23,0.00,42.05,9.70,42.18,15.15,44.03
~
第一行:K0+0是剖面名称(桩号),42.05是纵剖面桩点高程,42.00是水面高
第二行:距离1,高程1,距离1,高程1,***距离n,高程n
***纵剖面桩点的距离包含在剖面名称中,如K1+140提取出来的距离为1140m。
***水面高分为:1不需要水面高;2固定水面高;3 动态水面高
***中心点左边桩点的距离是负值,右边是正值。
2.2转换为其他格式的数据
由于生成剖面图的软件不同,设计单位的要求不同,剖面数据的格式有很多,为了给甲方提交测量数据,本程序中包含了几种常用格式的转换。(其他格式的转换仅仅是文本文件的读取和输出问题,有开发能力的同行很容易做到)
3程序设计的流程
3.1创建定位线选择集:历遍定位线选择集
3.2利用定位线扩展外框(3米)创建剖面名称选择集,查找并确定定位线的剖面名称
3.3利用定位线扩展外框(2米)创建高程点选择集,把每一个高程点垂直移动到定位线上
3.4按高程点到定位线起点的距离进行排序
3.5利用定位线与中心线的交点到中心线起点的距离对所有剖面线进行排序
3.6按顺序输出剖面数据
4程序界面
5核心源代码
Option Explicit
Dim 剖面名称图层 As String, 定位线图层 As String
Dim 高程点图层 As String, 高程点类型 As String
Dim 水位线选项 As Integer
Dim H0 As Double, Hn As Double, h1 As Double
Private Sub CommandButton1_Click()
Dim 文本块 As AcadSelectionSet, 定位线 As AcadSelectionSet
Dim 中心线 As AcadEntity, gcdObj As AcadEntity
Dim 中心线长 As Double
Dim n As Integer, i As Integer
Dim objBlock As Variant
Dim FType(1) As Integer, FData(1)
Dim pts As Collection, pt(0 To 1) As Double
Dim pt1 As Variant, pt2 As Variant
Dim xyS As Variant, xyE As Variant
Dim 剖面名称 As String, m As String
Dim 剖面线(), 线数 As Long
Dim Filename As String, mm As String
Dim 水面高程 As Double
On Error Resume Next
定位线图层 = ComboBox2.Text
剖面名称图层 = ComboBox3.Text
高程点图层 = ComboBox4.Text
高程点类型 = ComboBox1.Text
If OptionButton1.value = True Then
水位线选项 = 0
End If
If OptionButton2.value = True Then
水位线选项 = 1
H0 = Val(TextBox1.Text)
End If
If OptionButton3.value = True Then
水位线选项 = 2
Dim cbFm() As String
cbFm = Split(TextBox2.Text, "/", -1)
H0 = Val(cbFm(0))
Hn = Val(cbFm(1))
End If
提取剖面数据设置.Hide
ThisDrawing.Utility.GetEntity 中心线, xy, "选取中心线对象"
Filename = ThisDrawing.path & "\数轴式剖面数据.txt"
'桩号,桩点高程(纵剖面上的点),水面高程
'左侧(距离为负—右侧(距离为正)距离1,高程1,距离2,高程2,~,距离n,高程n
ThisDrawing.Utility.GetEntity 中心线, xy, "选取中心线对象"
中心线长 = 中心线.Length
ThisDrawing.SelectionSets.Item("通过点的选择集").Delete
Err.Clear
Set 文本块 = ThisDrawing.SelectionSets.Add("通过点的选择集")
Dim sh As Double, SH1 As Double
ThisDrawing.Application.ZoomExtents
Set pts = 多段线坐标集合(中心线)
ThisDrawing.SelectionSets.Item("定位线").Delete
Err.Clear
Set 定位线 = ThisDrawing.SelectionSets.Add("定位线") '定位线对象选择集
FType(0) = 8: FData(0) = 定位线图层
FType(1) = 0: FData(1) = "*LINE"
filtertype = FType: filterdata = FData
定位线.Select acSelectionSetAll, , , filtertype, filterdata
线数 = -1
'组织剖面定位线,按定位线到中心线起点的距离进行排序。
For Each Entry In 定位线
If Entry.Handle = 中心线.Handle Then GoTo 50
pt1 = 中心线.IntersectWith(Entry, acExtendNone)
If UBound(pt1) < 0 Then GoTo 50
Select Case Entry.ObjectName
Case "AcDb2dPolyline", "AcDbPolyline"
xyS = Entry.Coordinate(0)
xyE = Entry.Coordinate(1)
Case "AcDbLine"
xyS = Entry.startPoint
xyE = Entry.EndPoint
End Select
线数 = 线数 + 1
ReDim Preserve 剖面线(3, 线数)
剖面线(0, 线数) = 距离_2P(pt1, xyS) '0 定位线起点到中点的距离
剖面线(1, 线数) = 点到点集合起点的距离(pts, pt1) '1 定位线到中心线起点的距离,用于剖面线排序
剖面线(2, 线数) = xyS '2 起点坐标
剖面线(3, 线数) = xyE '3 纵点坐标
50:
Next
Call ArrayPaXu(剖面线, 0, 线数, 1, True)
Open Filename For Output As #1
For n = 0 To 线数
xyS = 剖面线(2, n)
xyE = 剖面线(3, n)
FType(0) = 8: FData(0) = 剖面名称图层
FType(1) = 0: FData(1) = "Text"
Call 二点扩展框(xyS, xyE, 3) '按两边拓展 3 米为范围选择 剖面名称 注记文本
文本块.Clear
filtertype = FType: filterdata = FData
文本块.SelectByPolygon acSelectionSetCrossingPolygon, pl, filtertype, filterdata
剖面名称 = Str(剖面线(1, n))
For Each gcdObj In 文本块
剖面名称 = gcdObj.TextString
Next
Do While pts.count > 0
pts.Remove index:=1
Loop
FType(0) = 8: FData(0) = 高程点图层
FType(1) = 0: FData(1) = 高程点类型
Call 二点扩展框(xyS, xyE, 2) '按两边拓展 2 米为范围选择展点高程块
文本块.Clear
filtertype = FType: filterdata = FData
文本块.SelectByPolygon acSelectionSetCrossingPolygon, pl, filtertype, filterdata
Debug.Print 剖面名称, 文本块.count
For Each gcdObj In 文本块
pt1 = gcdObj.insertionPoint
pt2 = 点到直线的垂足(xyS, xyE, pt1)
xy1(0) = pt2(0): xy1(1) = pt2(1)
gcdObj.insertionPoint = xy1 '高程点垂直移到定位线上
Select Case gcdObj.ObjectName
Case "AcDbText"
m = gcdObj.TextString
Case "AcDbBlockReference"
objBlock = gcdObj.GetAttributes
m = objBlock(0).TextString
End Select
pt(0) = 距离_2P(xyS, pt2) - 剖面线(0, n)
pt(1) = Val(m)
For i = 1 To pts.count
pt1 = pts(i)
If pt(0) < pt1(0) Then
pts.Add Item:=pt, Before:=i
GoTo 60
End If
Next
pts.Add Item:=pt
60: Next
Dim 中桩点高程 As Double
Dim s1 As Double, h1 As Double
Dim s2 As Double, h2 As Double
For i = 1 To pts.count
pt1 = pts(i)
If pt1(0) > 0 Then
pt2 = pts(i - 1)
s1 = Abs(pt2(0)): h1 = pt2(1)
s2 = pt1(0): h2 = pt1(1)
中桩点高程 = h1 + s1 * (h2 - h1) / (s1 + s2)
Exit For
End If
Next
Select Case 水位线选项
Case 0 '无水面高程
水面高程 = "-1000"
Case 1 '固定水面高程
水面高程 = H0
Case 2 '动态水面高程
水面高程 = H0 + 剖面线(1, n) * (Hn - H0) / 中心线长
End Select
Print #1, 剖面名称 + "," + Format(中桩点高程, "0.00") + "," + Format(水面高程, "0.00")
Print #1, 点集合转长字符串(pts)
Next
Close
文本块.Delete
定位线.Delete
MsgBox "恭喜你,完成啦!"
Unload Me
End Sub
Private Sub CommandButton2_Click()
Dim WshShell As Object, Filename As String
Set WshShell = CreateObject("WScript.Shell")
Filename = VBApath + "\剖面数据格式.txt"
WshShell.Run "Notepad " & Filename
Set WshShell = Nothing
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer, l1 As Integer, l2 As Integer, l3 As Integer
'高程点类型
ComboBox1.AddItem "INSERT"
ComboBox1.AddItem "Text"
ComboBox1.ListIndex = 0
Dim newlayer As AcadLayer
i = 0
For Each newlayer In ThisDrawing.Layers
l1 = IIf(newlayer.Name = "SZ-ZH-DIM" Or newlayer.Name = "Pile-下穿2" Or newlayer.Name = "定位线", i, l1)
l2 = IIf(newlayer.Name = "SZ-ZH-DIM" Or newlayer.Name = "Pile-下穿2" Or newlayer.Name = "剖面名称", i, l2)
l3 = IIf(newlayer.Name = "GCD", i, l3)
ComboBox2.AddItem newlayer.Name '定位线图层名
ComboBox3.AddItem newlayer.Name '剖面名称图层名
ComboBox4.AddItem newlayer.Name '高程点图层名
i = i + 1
Next newlayer
ComboBox2.ListIndex = l1
ComboBox3.ListIndex = l2
ComboBox4.ListIndex = l3
ComboBox6.AddItem "南京捷鹰" '双翅逗号纵横合一
ComboBox6.AddItem "双翅空格"
ComboBox6.AddItem "Excel表"
ComboBox6.AddItem "Cass格式"
ComboBox6.ListIndex = 0
End Sub
Private Sub CommandButton3_Click()
Dim Filename As String, 横FileName As String, 纵FileName As String
Dim strm() As String, pmxx() As String
Dim path As String, mm As String
Dim i As Integer
On Error Resume Next
Open VBApath & "path.txt" For Input As #1
Input #1, path
Close
Filename = GetOpenFile("查找数轴格式剖面数据文件", "文本文件 Files(*.txt), Profile.hdm", path)
If Filename = "" Then Exit Sub
strm = Split(Filename, "\", -1)
ReDim Preserve strm(UBound(strm) - 1)
path = Join(strm, "\")
Select Case ComboBox6.Text
Case "南京捷鹰" '桩号,距离1,高程1,.......距离n,高程n<>
横FileName = path & "\NJJYpm.txt"
Open Filename For Input As #1
Open 横FileName For Output As #2
While Not (EOF(1))
Line Input #1, mm
strm = Split(LTrim(mm), ",", -1)
path = strm(0)
Line Input #1, mm
pl = 长字符串转数组(mm)
Dim 左边距离 As Double
左边距离 = pl(0)
For i = 0 To UBound(pl) Step 2
pl(i) = pl(i) - 左边距离 '距离改为左侧定位的距离
Next
Print #2, path + "," + RealArrayJoin(pl, ",", True, False) + "<>"
Wend
Close
Case "双翅空格"
横FileName = path & "\hdx.txt"
纵FileName = path & "\dmx.txt"
Open Filename For Input As #1
Open 横FileName For Output As #2
Open 纵FileName For Output As #3
While Not (EOF(1))
Line Input #1, mm
strm = Split(LTrim(mm), ",", -1)
Print #3, Str(截取距离(strm(0))) + "," + strm(1)
Line Input #1, mm
Dim 左数组() As Double, 右数组() As Double
pl = CStringToRealArray(mm, ",", 左数组, 右数组)
Print #2, strm(0) + " " + RealArrayJoin(左数组, " ", False, True) '反向,取绝对值
Print #2, RealArrayJoin(右数组, " ", True, False) '顺向,不取绝对值
Wend
Close
Case "Excel表" '数轴式数据序列
横FileName = path & "\Profile.xlsx"
Dim 行 As Integer, 列 As Integer, n As Integer
Call 创建Excel文件
If xlBook.Worksheets.count < 2 Then
xlBook.Worksheets.Add
End If
xlBook.Worksheets(1).Name = "横剖面"
xlBook.Worksheets(2).Name = "纵剖面"
Set xlSheet = xlBook.Worksheets(2)
列 = 1: n = 0
Open Filename For Input As #1
While Not (EOF(1))
With xlApp.Worksheets("横剖面")
Line Input #1, mm
strm = Split(LTrim(mm), ",", -1)
'纵剖面数据
n = n + 1
xlSheet.Cells(n, 1) = 截取距离(strm(0)) '4 定位线到中心线起点的距离
xlSheet.Cells(n, 2) = strm(1) '3 纵剖面桩点(中心线与剖面定位线的交点)的高程
行 = 1
.Cells(行, 列) = strm(0) '剖面名称
.Cells(行, 列 + 1) = strm(2) '水面高程
'以下创建数据验证
With xlApp.Worksheets("横剖面").Range(.Cells(1, 列 + 2), .Cells(1, 列 + 2)).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="无,高程,高差"
.i
End With
.Cells(1, 列 + 2) = "无"
Line Input #1, mm
strm = Split(LTrim(mm), ",", -1)
For i = 0 To UBound(strm) Step 2
行 = 行 + 1
.Cells(行, 列) = strm(i) '桩点到定位线起点的距离
.Cells(行, 列 + 1) = strm(i + 1) '桩点高程
Next
列 = 列 + 3
End With
Wend
Close
xlBook.SaveAs (横FileName)
xlBook.Close
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Case "Cass格式"
横FileName = path & "\hdm.hdm"
纵FileName = path & "\zdm.zdm"
Open Filename For Input As #1
Open 横FileName For Output As #2
Open 纵FileName For Output As #3
Print #3, "BEGIN,纵断面"
While Not (EOF(1))
Line Input #1, mm '桩号,高程,水面高程
strm = Split(LTrim(mm), ",", -1)
Print #3, Str(截取距离(strm(0))) + "," + strm(1)
Print #2, "BEGIN," + strm(0)
Line Input #1, mm
strm = Split(LTrim(mm), ",", -1)
For i = 0 To UBound(strm) Step 2
Print #2, strm(i) + "," + strm(i + 1)
Next
Wend
Close
End Select
MsgBox "恭喜你,完成啦!"
End Sub
Public Function 点集合转长字符串(pts As Collection) As String
Dim i As Integer
Dim mm As String
Dim pt As Variant
On Error Resume Next
pt = pts(1)
mm = Format(pt(0), "0.00") + "," + Format(pt(1), "0.00")
For i = 2 To pts.count
pt = pts(i)
mm = mm + "," + Format(pt(0), "0.00") + "," + Format(pt(1), "0.00")
Next
点集合转长字符串 = mm
End Function
Public Function 长字符串转数组(mm As String) As Double()
Dim strm() As String, data() As Double, i As Integer
strm = Split(LTrim(mm), ",", -1)
ReDim data(UBound(strm))
For i = 0 To UBound(strm)
data(i) = Val(strm(i))
Next
长字符串转数组 = data
End Function
'长字符串转为实数数组:函数返回全部无素的数组,左数组返回左边负值的元素,右数组返回右边正值的元素。
Public Function CStringToRealArray(mm As String, 连接符 As String, 左数组() As Double, 右数组() As Double) As Double()
Dim m() As String
Dim RealArray() As Double
Dim i As Integer, Left As Integer, Right As Integer
m = Split(mm, 连接符, -1)
ReDim RealArray(UBound(m))
For i = 0 To UBound(m) Step 2
RealArray(i) = Val(m(i))
RealArray(i + 1) = Val(m(i + 1))
If RealArray(i) < 0 Then
ReDim Preserve 左数组(Left + 1)
左数组(Left) = RealArray(i)
左数组(Left + 1) = RealArray(i + 1)
Left = Left + 2
Else
ReDim Preserve 右数组(Right + 1)
右数组(Right) = RealArray(i)
右数组(Right + 1) = RealArray(i + 1)
Right = Right + 2
End If
Next
CStringToRealArray = RealArray
End Function
'实数数组(每二个元素为一组,如:距离1,高程1,距离2,高程2......)转为长字符串
'方向=false时,点顺序反向
'绝对值=true时所有距离取绝对值,
Public Function RealArrayJoin(RealArray() As Double, 连接符 As String, 方向 As Boolean, 绝对值 As Boolean) As String
Dim strm() As String, i As Integer
ReDim strm(UBound(RealArray))
If 方向 = True Then
For i = 0 To UBound(RealArray) Step 2
strm(i) = IIf(绝对值 = True, Str(Abs(RealArray(i))), Str(RealArray(i)))
strm(i + 1) = Str(RealArray(i + 1))
Next
Else
Dim r As Integer
For i = UBound(RealArray) To 0 Step -2
strm(r) = IIf(绝对值 = True, Str(Abs(RealArray(i - 1))), Str(RealArray(i - 1)))
strm(r + 1) = Str(RealArray(i))
r = r + 2
Next
End If
RealArrayJoin = Join(strm, 连接符)
End Function
'取出桩号中的数字部份,作为纵剖面的距离
Function 分析标题(mm As String, 水面高程 As Double, 距离 As Double, 桩点高程 As Double) As String
Dim strm() As String
On Error Resume Next
strm = Split(LTrim(mm), ",", -1)
水面高程 = Val(strm(2))
桩点高程 = Val(strm(1))
距离 = 截取距离(strm(0))
分析标题 = strm(0)
End Function
Function 截取距离(mm As String) As Double
Dim m As String, i As Integer, j As Integer
On Error Resume Next
j = Len(mm)
If IsNumeric(Right(mm, j - 1)) = True Then
截取距离 = Val(Right(mm, j - 1))
Exit Function
End If
i = InStr(mm, "+")
If i > 0 Then m = Mid(mm, i + 1, j - i)
i = InStr(mm, "-")
If i > 0 Then m = Mid(mm, i + 1, j - i)
截取距离 = 1000 * Val(Mid(mm, 2, 1)) + Val(m)
End Function
Public Function 多段线坐标集合(Eobj As AcadEntity) As Collection
Dim i As Integer, j As Integer
Dim pts As New Collection
Dim pt(0 To 2) As Double
xy = Eobj.Coordinates
r = IIf(Eobj.ObjectName = "AcDbPolyline", 2, 3)
For i = 0 To UBound(xy) Step r
pt(0) = xy(i): pt(1) = xy(i + 1): pt(2) = 0
pts.Add pt
Next
Set 多段线坐标集合 = pts
End Function
Public Function 点到点集合起点的距离(pts As Collection, Point As Variant) As Double
Dim i As Integer, r As Integer
Dim pt1 As Variant, pt2 As Variant
Dim S As Double
For i = 1 To pts.count
r = IIf(i = pts.count, 1, i + 1)
pt1 = pts.Item(i)
pt2 = pts.Item(r)
If 点在线段中间(pt1, pt2, Point) = True Then
点到点集合起点的距离 = S + 距离_2P(pt1, Point)
Exit Function
End If
S = S + 距离_2P(pt1, pt2)
Next
点到点集合起点的距离 = -1
End Function
Function 距离_2P(ByVal Axy As Variant, ByVal Bxy As Variant) As Double
Dim X As Double, Y As Double, Z As Double
X = Bxy(0) - Axy(0): Y = Bxy(1) - Axy(1)
If UBound(Axy) = 2 And UBound(Bxy) = 2 Then
Z = Bxy(2) - Axy(2)
Else
Z = 0
End If
距离_2P = Sqr(X ^ 2 + Y ^ 2 + Z ^ 2)
End Function
Public Function 点到直线的垂足(xyA As Variant, xyB As Variant, xyc As Variant) As Double()
'xya 为直线的起点,xyb 为直线的终点,xyc 为第三点,XYd 为返回点坐标
Dim Qa As Double, qb As Double, xabc(0 To 1) As Double
If Abs((xyB(0) - xyA(0))) < 0.000001 Then
xabc(0) = xyA(0)
xabc(1) = xyc(1)
Else
Qa = (xyB(1) - xyA(1)) / (xyB(0) - xyA(0))
qb = xyc(0) / Qa + Qa * xyA(0) - xyA(1) + xyc(1)
xabc(0) = (xyc(0) / Qa + Qa * xyA(0) - xyA(1) + xyc(1)) / (Qa + 1 / Qa)
xabc(1) = Qa * xabc(0) - Qa * xyA(0) + xyA(1)
End If
点到直线的垂足 = xabc
End Function
Public Sub ArrayPaXu(ArrayB As Variant, starRow As Long, endRow As Long, KeyColumn As Integer, Order As Boolean)
' 数组排序 数组 起始行 终止行 关徤列 是否升序
Dim i As Long, j As Long, n As Integer, APM As Variant 'Currency
Dim bm As Variant, Ffm As Boolean
Ffm = IsNumeric(ArrayB(KeyColumn, starRow)) '是否数字
For i = starRow To endRow
For j = starRow To endRow - 1
Select Case Ffm
Case True '数字
If Val(ArrayB(KeyColumn, j)) = Val(ArrayB(KeyColumn, j + 1)) Then GoTo 100
APM = IIf(Val(ArrayB(KeyColumn, j)) < Val(ArrayB(KeyColumn, j + 1)), -1, 1)
Case False '字符串
APM = StrComp(ArrayB(KeyColumn, j), ArrayB(KeyColumn, j + 1), 1)
If APM = Null Or APM = 0 Then GoTo 100
End Select
Select Case Order
Case True '升序
If APM = -1 Then GoTo 100
Case False '降序
If APM = 1 Then GoTo 100
End Select
For n = LBound(ArrayB) To UBound(ArrayB)
bm = ArrayB(n, j)
ArrayB(n, j) = ArrayB(n, j + 1)
ArrayB(n, j + 1) = bm
Next n
100: Next j
Next i
End Sub