剖面及土方测量是较常见的工程测量项目,早期剖面测量采用的经纬仪导线放线,测量地形变换点的高程,现在使用 GPS放线测量地形变换点的高程,极大地提高了效率。 前文《剖面测量之提取剖面数据》介绍了如何提取图面高程点整理并输出剖面数据,本文件介绍如何绘制图面图。
目前,在AuToCAD上二次开发的软件有很多剖面绘制的程序,但随着剖面图在工程设计及施工中的广泛应用,传统的剖面图已不能满足需要,有时需要在剖面图中叠加淤泥线;有时设计部门要求剖面图叠加设计剖面并计算清淤土方量。
1标准剖面绘制
1.1流程
1)从剖面数据文件读入数据,筛选出最长距离、最大高程、最小高程;
2)定义并绘制坐标系块,供每条剖面绘制时插入;
3)逐条绘制剖面图(平面与高程均为1/100)。
1.2剖面图的式样
1.3界面设计
2叠加淤泥线的剖面图
2.1数据格式
每三列为一条剖面,第一列是距离、第二列是高程、第三列是淤泥线数据,淤泥线数据的第一行有三个选项:无、高程、高差。
没有淤泥线数据时为无;
淤泥线数据是淤泥底的高程时选高程;
淤泥线数据是相对于剖面线的高差时选高差,剖面线在淤泥底时高差为正、剖面线在淤泥顶时高差为负。
淤泥线数据头尾只有一个0
下图是叠加淤泥线的剖面图,红色线是剖面线,填充图案是淤泥的截面积。
2.2淤泥量计算
其中:H 二个桩号间的长度
S1 前一条剖面的淤泥截面积
S2 后一条剖面的淤泥截面积
3核心源代码
剖面绘制Form:
Dim 网格线间隔 As Integer, 引线长度 As Boolean
Dim 过滤器 As String, path As String, 定位 As String
Dim 块名 As String
Dim 剖面线(), 线数 As Long
Private Sub OptionButton10_Click()
If OptionButton10.value = True Then 定位 = "中心定位"
End Sub
Private Sub OptionButton11_Click()
If OptionButton11.value = True Then 定位 = "左边定位"
End Sub
Private Sub OptionButton5_Click()
引线长度 = True
End Sub
Private Sub OptionButton6_Click()
引线长度 = False
End Sub
Private Sub OptionButton4_Click()
网格线间隔 = -100
End Sub
Private Sub OptionButton7_Click()
网格线间隔 = 2
End Sub
Private Sub OptionButton8_Click()
网格线间隔 = 5
End Sub
Private Sub OptionButton9_Click()
网格线间隔 = 10
End Sub
Private Sub UserForm_Initialize()
ThisDrawing.SendCommand "_-purge" + vbCr + "a" + vbCr + vbCr + "n" + vbCr '清块
网格线间隔 = 10
引线长度 = True
定位 = "中心定位"
End Sub
Private Sub CheckBox4_Click()
Dim mm As String
If CheckBox4.value <> True Then Exit Sub
PmFile0.Text = GetOpenFile("查找数轴格式剖面数据文件", "文本文件 Files(*.txt), Profile.hdm", path)
If PmFile0.Text = PmFile.Text Then
MsgBox "二个剖面文件是同一个,无法完成绘制!"
CheckBox4.value = False
Exit Sub
End If
If Dir(PmFile0.Text) = "" Then
MsgBox "初测剖面文件不存在,无法完成绘制!"
CheckBox4.value = False
Exit Sub
End If
'读入要叠加的旧剖面线数据
线数 = -1
Call AddLayer("剖面线0", 2)
Open PmFile0.Text For Input As #2
While Not (EOF(2))
Line Input #2, mm
Line Input #2, mm
pl = 长字符串转实数数组(mm)
线数 = 线数 + 1
ReDim Preserve 剖面线(1, 线数)
剖面线(0, 线数) = (UBound(pl) - 1) / 2
剖面线(1, 线数) = pl
Wend
Close
End Sub
Private Sub 标准文件_Click()
Dim nL As Integer, N As Integer, i As Integer
Dim 剖面名称 As String, mm As String
Dim Ixy(0 To 2) As Double
Dim H小 As Double, H大 As Double, H水 As Double, 水面高程 As Double
Dim 左线长 As Double, 右线长 As Double
Dim 总线长 As Double, 线长 As Double
Dim sL As Double, sR As Double
Dim 行 As Integer, 行高 As Double, 控制行数 As Integer
Dim 列 As Integer, 列宽 As Double
Dim strm(0 To 1) As Double, JiuPm() As Double
Dim blockObj As AcadBlockReference
Dim 左边距离 As Double
Dim 前缀 As String
Dim PmFile As String
On Error Resume Next
PmFile = GetOpenFile("查找数轴格式剖面数据文件", "文本文件 Files(*.txt), Profile.hdm", path)
If Dir(PmFile) = "" Then Exit Sub
ThisDrawing.SendCommand "_-purge" + vbCr + "a" + vbCr + vbCr + "n" + vbCr '清块
控制行数 = 每行条数.value
前缀 = 桩号前缀.Text
'加载线型
ThisDrawing.Linetypes.Load "DASHEDX2,Dashed (2x)", "acad.lin"
ThisDrawing.Linetypes.Load "ACAD_ISO03W100", "acadiso.lin"
Call 创建文本式样("pmtextStyle", "宋体", False, False)
Call AddLayer("坐标系", 7)
Call AddLayer("剖面线", 1)
Call AddLayer("剖面名称", 1)
Call AddLayer("引线", 157)
Call AddLayer("水位线", 5)
'找出 最大高程、最小高程、最大距离
H小 = 10000: H大 = 0: 最大线长 = 0: 总线长 = 0
Open PmFile For Input As #1
While Not (EOF(1))
Line Input #1, mm
'第一次读左侧数据,第二次读右侧数据
Line Input #1, mm
pl = 长字符串转实数数组(mm)
N = UBound(pl)
sL = Abs(pl(0))
左线长 = IIf(sL > 左线长, sL, 左线长) '左边的最长距离
sR = pl(N - 1)
右线长 = IIf(sR > 右线长, sR, 右线长) '右边的最长距离
线长 = IIf((sL + sR) > 线长, (sL + sR), 线长) '合计最长距离
总线长 = 总线长 + sL + sR
For i = 0 To N Step 2
H小 = IIf(pl(i + 1) < H小, pl(i + 1), H小)
H大 = IIf(pl(i + 1) > H大, pl(i + 1), H大)
Next
Wend
Close
H小 = Int(H小) - 2 '剖面原点的高程值
H大 = 2 + Int(H大)
Dim ptL(0 To 2) As Double, ptR(0 To 2) As Double
Select Case 定位
Case "中心定位"
ptL(0) = -10 * Int(左线长 + 1)
ptL(1) = 0
ptR(0) = 10 * Int(右线长 + 1)
ptR(1) = 10 * (H大 - H小)
列宽 = 200 + Int((左线长 + 右线长) * 10)
行高 = 80 + Int((H大 - H小) * 10)
块名 = "CentreSystem"
Case "左边定位"
ptL(0) = 0
ptL(1) = 0
ptR(0) = 10 * Int(线长 + 1)
ptR(1) = 10 * (H大 - H小)
列宽 = 200 + Int((线长 + 1) * 10)
行高 = 80 + Int((H大 - H小) * 10)
块名 = "LeftSystem"
End Select
Call 创建剖面坐标系(块名, ptL, ptR, H大, H小, 网格线间隔)
nL = -1
Dim 纵剖面() As Double
Open PmFile For Input As #1
While Not (EOF(1))
Input #1, strm(0), strm(1), 水面高程
nL = nL + 1
ReDim Preserve 纵剖面(nL * 2 + 1)
剖面名称 = 桩号to名称(前缀, strm(0))
纵剖面(nL * 2) = strm(0)
纵剖面(nL * 2 + 1) = strm(1)
行 = nL Mod 控制行数
列 = Int(nL / 控制行数)
'插入点
Ixy(0) = 10000 + 列 * 列宽
Ixy(1) = 20000 - 行 * 行高
Set blockObj = ThisDrawing.ModelSpace.InsertBlock(Ixy, 块名, 1, 1, 1, 0)
blockObj.Layer = "坐标系"
Line Input #1, mm
pl = 长字符串转实数数组(mm)
N = UBound(pl)
左边距离 = IIf(定位 = "中心定位", 0, pl(0))
For i = 0 To N Step 2
Dim m1 As String, m2 As String
m1 = Format(pl(i + 1), "0.00")
m2 = Format((pl(i) - 左边距离), "0.00")
pl(i) = Ixy(0) + 10 * (pl(i) - 左边距离)
pl(i + 1) = Ixy(1) + 10 * pl(i + 1) - 10 * H小
xy1(0) = pl(i)
xy1(1) = pl(i + 1)
xy2(0) = pl(i)
xy2(1) = Ixy(1) - 40
If 引线长度 = False Then xy1(1) = Ixy(1)
Call AddLine(xy1, xy2, "引线")
xy1(0) = xy1(0) + 0.5
xy1(1) = Ixy(1) - 19
Call AddText(m1, xy1, 4, "坐标系", 7, 6, 0, 1.57)
xy1(1) = Ixy(1) - 39
Call AddText(m2, xy1, 4, "坐标系", 7, 6, 0, 1.57)
Next
Call 轻便多段线(pl, "剖面线", False, 1, 0.3)
xy1(0) = IIf(定位 = "中心定位", Ixy(0) - 10, Ixy(0) + 5 * 线长 - 10)
xy1(1) = Ixy(1) + 10 * (H大 - H小) + 15
Call AddText(剖面名称, xy1, 8, "剖面名称", 7, 13)
If 水面高程 <> -1000 Then '标绘水面高
xy1(0) = pl(0)
xy1(1) = Ixy(1) + 10 * (水面高程 - H小)
xy2(0) = pl(N - 1)
xy2(1) = Ixy(1) + 10 * (水面高程 - H小)
Call AddLine(xy1, xy2, "水位线")
xy2(0) = (xy1(0) + xy2(0)) / 2 - 10
xy2(1) = xy2(1) + 1
Call AddText("水位线:" & Format(水面高程, "0.00"), xy2, 4, "水位线")
End If
'绘画叠加的旧剖面线
If CheckBox4.value = True Then
JiuPm = 剖面线(1, nL)
For i = 0 To 剖面线(0, nL)
JiuPm(i * 2) = Ixy(0) + 10 * (JiuPm(i * 2) - 左边距离)
JiuPm(i * 2 + 1) = Ixy(1) + 10 * JiuPm(i * 2 + 1) - 10 * H小
Next
Call 轻便多段线(JiuPm, "剖面线0", False, 2, 0.2)
End If
Wend
Close
线长 = 纵剖面(nL * 2)
总线长 = 总线长 + 线长
Ixy(0) = IIf(定位 = "中心定位", 10000 - 10 * Int(左线长 + 1), 10000) '插入点从中心移到左侧
Ixy(1) = 20150 + 10 * (H大 - H小)
ptL(0) = 0
ptL(1) = 0
ptR(0) = 10 * Int(线长 + 1)
ptR(1) = 10 * (H大 - H小)
Call 纵剖面画线(纵剖面, Ixy, ptL, ptR, H大, H小)
xy1(0) = Ixy(0) + (ptR(0) - ptL(0)) / 2 - 60
xy1(1) = Ixy(1) + 10 * (H大 - H小) + 60
mm = "共绘制横剖面: " + str(nL + 1) + " 条;纵剖面 1 条。剖面线总长度= " + Format(总线长, "0.00") + "米。"
Call AddText(mm, xy1, 20, "坐标系")
ThisDrawing.Application.ZoomExtents
ThisDrawing.Regen acActiveViewport
MsgBox "恭喜你,完成啦!"
Unload Me
End Sub
Private Sub Excel文件_Click()
Dim nL As Integer, N As Integer, i As Integer
Dim 剖面名称 As String, mm As String
Dim Ixy(0 To 2) As Double
Dim H小 As Double, H大 As Double, H水 As Double, 水面高程 As Double
Dim 左线长 As Double, 右线长 As Double
Dim 总线长 As Double, 线长 As Double
Dim sL As Double, sR As Double
Dim 行 As Integer, 行高 As Double, 控制行数 As Integer
Dim 列 As Integer, 列宽 As Double
Dim JiuPm() As Double
Dim blockObj As AcadBlockReference
Dim 淤泥点() As Double, 淤泥点数 As Integer
Dim 左边距离 As Double
Dim ynArea() As Variant, 淤泥量 As Double
Dim 前缀 As String
Dim 纵剖面() As Double
Dim PmFile As String
On Error Resume Next
前缀 = 桩号前缀
PmFile = GetOpenFile("查找剖面数据(Excel文件)", "剖面数据文件(*.xls)" & vbNullChar & "*.xlsx", path)
If Dir(PmFile) = "" Then Exit Sub
ThisDrawing.SendCommand "_-purge" + vbCr + "a" + vbCr + vbCr + "n" + vbCr '清块
控制行数 = 每行条数.value
'加载线型
ThisDrawing.Linetypes.Load "DASHEDX2,Dashed (2x)", "acad.lin"
ThisDrawing.Linetypes.Load "ACAD_ISO03W100", "acadiso.lin"
Call 创建文本式样("pmtextStyle", "宋体", False, False)
Call AddLayer("坐标系", 7)
Call AddLayer("剖面线", 1)
Call AddLayer("剖面名称", 1)
Call AddLayer("淤泥底线", 235)
Call AddLayer("引线", 157)
Call AddLayer("水位线", 5)
'找出 最大高程、最小高程、最大距离
H小 = 10000: H大 = 0: 最大线长 = 0: 总线长 = 0
Workbooks.Open FileName:=PmFile '打开文件
With ActiveWorkbook.Sheets("横剖面")
N = 1
Do While .Cells(1, N) <> ""
sL = Abs(.Cells(2, N))
左线长 = IIf(sL > 左线长, sL, 左线长) '左边的最长距离
i = 2
Do While .Cells(i, N) <> ""
sR = .Cells(i, N)
右线长 = IIf(sR > 右线长, sR, 右线长) '右边的最长距离
线长 = IIf((sL + sR) > 线长, (sL + sR), 线长) '合计最长距离
H小 = IIf(.Cells(i, N + 1) < H小, .Cells(i, N + 1), H小)
H大 = IIf(.Cells(i, N + 1) > H大, .Cells(i, N + 1), H大)
i = i + 1
Loop
总线长 = 总线长 + sL + sR
N = N + 3
Loop
H小 = Int(H小) - 2 '剖面原点的高程值
H大 = 2 + Int(H大)
Dim ptL(0 To 2) As Double, ptR(0 To 2) As Double
Select Case 定位
Case "中心定位"
ptL(0) = -10 * Int(左线长 + 1)
ptL(1) = 0
ptR(0) = 10 * Int(右线长 + 1)
ptR(1) = 10 * (H大 - H小)
列宽 = 200 + Int((左线长 + 右线长) * 10)
行高 = 80 + Int((H大 - H小) * 10)
块名 = "CentreSystem"
Case "左边定位"
ptL(0) = 0
ptL(1) = 0
ptR(0) = 10 * Int(线长 + 1)
ptR(1) = 10 * (H大 - H小)
列宽 = 200 + Int((线长 + 1) * 10)
行高 = 80 + Int((H大 - H小) * 10)
块名 = "LeftSystem"
End Select
Call 创建剖面坐标系(块名, ptL, ptR, H大, H小, 网格线间隔)
N = 1
nL = -1
Dim 间隔 As Double
Do While .Cells(1, N) <> ""
If N > 1 Then
间隔 = .Cells(1, N) - .Cells(1, N - 3)
End If
剖面名称 = 桩号to名称(前缀, .Cells(1, N))
水面高程 = .Cells(1, N + 1)
nL = nL + 1
行 = nL Mod 控制行数
列 = Int(nL / 控制行数)
'插入点
Ixy(0) = 10000 + 列 * 列宽
Ixy(1) = 20000 - 行 * 行高
Set blockObj = ThisDrawing.ModelSpace.InsertBlock(Ixy, 块名, 1, 1, 1, 0)
blockObj.Layer = "坐标系"
i = 2
淤泥点数 = -1
左边距离 = IIf(定位 = "中心定位", 0, .Cells(2, N))
Do While .Cells(i, N) <> ""
nR = i - 2
ReDim Preserve pl(nR * 2 + 1)
pl(nR * 2) = Ixy(0) + 10 * (.Cells(i, N) - 左边距离)
pl(nR * 2 + 1) = Ixy(1) + 10 * (.Cells(i, N + 1) - H小)
If .Cells(i, N + 2) <> "" And .Cells(1, N + 2) <> "无" Then
淤泥点数 = 淤泥点数 + 1
ReDim Preserve 淤泥点(淤泥点数 * 2 + 1)
淤泥点(淤泥点数 * 2) = Ixy(0) + 10 * (.Cells(i, N) - 左边距离)
Select Case .Cells(1, N + 2)
Case "高程"
淤泥点(淤泥点数 * 2 + 1) = Ixy(1) + 10 * (.Cells(i, N + 2) - H小)
Case "高差"
淤泥点(淤泥点数 * 2 + 1) = Ixy(1) + 10 * (.Cells(i, N + 1) + .Cells(i, N + 2) - H小)
End Select
End If
xy1(0) = pl(nR * 2)
xy1(1) = pl(nR * 2 + 1)
xy2(0) = pl(nR * 2)
xy2(1) = Ixy(1) - 40
If 引线长度 = False Then xy1(1) = Ixy(1)
Call AddLine(xy1, xy2, "引线")
xy1(0) = xy1(0) + 0.5
xy1(1) = Ixy(1) - 19
mm = Format(.Cells(i, N + 1), "0.00")
Call AddText(mm, xy1, 4, "坐标系", 7, 6, 0, 1.57)
xy1(1) = Ixy(1) - 39
mm = Format(.Cells(i, N), "0.00")
Call AddText(mm, xy1, 4, "坐标系", 7, 6, 0, 1.57)
i = i + 1
Loop
Call 轻便多段线(pl, "剖面线", False, 1, 0.3)
xy1(0) = IIf(定位 = "中心定位", Ixy(0) - 10, Ixy(0) + 5 * 线长 - 10)
xy1(1) = Ixy(1) + 10 * (H大 - H小) + 15
Call AddText(剖面名称, xy1, 8, "剖面名称")
'标绘水面高
If 水面高程 <> -1000 Then
xy1(0) = pl(0)
xy1(1) = Ixy(1) + 10 * (水面高程 - H小)
xy2(0) = pl(nR * 2)
xy2(1) = Ixy(1) + 10 * (水面高程 - H小)
Call AddLine(xy1, xy2, "水位线")
xy2(0) = (xy1(0) + xy2(0)) / 2 - 10
xy2(1) = xy2(1) + 1
Call AddText("水位线:" & Format(水面高程, "0.00"), xy2, 4, "水位线")
End If
'绘画叠加的旧剖面线
If CheckBox4.value = True Then
JiuPm = 剖面线(1, nL)
For i = 0 To 剖面线(0, nL)
JiuPm(i * 2) = Ixy(0) + 10 * (JiuPm(i * 2) - 左边距离)
JiuPm(i * 2 + 1) = Ixy(1) + 10 * JiuPm(i * 2 + 1) - 10 * H小
Next
Call 轻便多段线(JiuPm, "剖面线0", False, 2, 0.2)
End If
'画淤泥线
ReDim Preserve ynArea(3, nL)
ynArea(0, nL) = 剖面名称
ynArea(1, nL) = 间隔
If 淤泥点数 > 0 Then
Call 轻便多段线(淤泥点, "淤泥底线", False, 235, 0.2)
ynArea(2, nL) = 计算淤泥面积(pl, 淤泥点)
If nL > 0 And ynArea(2, nL) > 0 And ynArea(2, nL - 1) > 0 Then
ynArea(3, nL) = (1 / 3) * 间隔 * (ynArea(2, nL) + ynArea(2, nL - 1) + Sqr(ynArea(2, nL) * ynArea(2, nL - 1)))
淤泥量 = 淤泥量 + ynArea(3, nL)
End If
End If
N = N + 3
Loop
End With
'Open ThisDrawing.path + "\淤泥面积.txt" For Output As #1
' For i = 1 To nL
' Print #1, ynArea(0, i), ynArea(1, i), Format(ynArea(2, i), "0.000000"), Format(ynArea(3, i), "0.00")
' Next
' Write #1, "淤泥量 =", Format(淤泥量, "0.00"), "立方米"
'Close
Ixy(0) = 10000 - 10 * Int(左线长 + 1)
Ixy(1) = 20150 + 10 * (H大 - H小)
With ActiveWorkbook.Sheets("纵剖面")
N = 1
Do While .Cells(N, 1) <> ""
ReDim Preserve 纵剖面((N - 1) * 2 + 1)
纵剖面((N - 1) * 2) = .Cells(N, 1)
纵剖面((N - 1) * 2 + 1) = .Cells(N, 2)
N = N + 1
Loop
End With
线长 = 纵剖面(nL * 2)
总线长 = 总线长 + 线长
Ixy(0) = IIf(定位 = "中心定位", 10000 - 10 * Int(左线长 + 1), 10000) '插入点从中心移到左侧
Ixy(1) = 20150 + 10 * (H大 - H小)
ptL(0) = 0
ptL(1) = 0
ptR(0) = 10 * Int(线长 + 1)
ptR(1) = 10 * (H大 - H小)
Call 纵剖面画线(纵剖面, Ixy, ptL, ptR, H大, H小)
xy1(0) = Ixy(0) + (ptR(0) - ptL(0)) / 2 - 60
xy1(1) = Ixy(1) + 10 * (H大 - H小) + 60
mm = "共绘制横剖面: " + str(nL + 1) + " 条;纵剖面 1 条。剖面线总长度= " + Format(总线长, "0.00") + "米。"
Call AddText(mm, xy1, 20, "坐标系")
ActiveWorkbook.Close
ThisDrawing.Application.ZoomExtents
ThisDrawing.Regen acActiveViewport
Dim ybFile As String, FileName As String
ybFile = VBApath & "相关文件\淤泥量计算表.xlsx"
FileName = ThisDrawing.path & "\淤泥量计算表.xlsx"
If Dir(FileName) = "" Then
FileCopy ybFile, FileName
End If
Workbooks.Open FileName:=FileName '打开文件
With ActiveWorkbook.Sheets(1)
For i = 0 To nL
.Cells(i + 3, 1) = ynArea(0, i)
.Cells(i + 3, 2) = ynArea(1, i)
.Cells(i + 3, 3) = Format(ynArea(2, i), "0.000000")
.Cells(i + 3, 4) = Format(ynArea(3, i), "0.00")
Next
End With
ActiveWorkbook.Close (True)
MsgBox "恭喜你,完成啦!"
Unload Me
End Sub