软件
产品
剖面及土方测量是较常见的工程测量 项目 ，早期剖面测量采用的经纬仪导线放线，测量地形变换点的高程，现在使用 GPS放线测量地形变换点的高程，极大地提高了效率。 前文《剖面测量之提取剖面数据》介绍了如何提取图面高程点整理并输出剖面数据，本文件介绍如何绘制图面图。
目前，在AuToCAD上二次开发的软件有很多剖面绘制的程序，但随着剖面图在工程设计及施工中的广泛应用，传统的剖面图已不能满足需要，有时需要在剖面图中叠加淤泥线；有时设计部门要求剖面图叠加设计剖面并计算清淤土方量。
1）从剖面数据文件读入数据，筛选出最长距离、最大高程、最小高程；
2）定义并绘制坐标系块，供每条剖面绘制时插入；
3）逐条绘制剖面图（平面与高程均为1/100）。
每三列为一条剖面，第一列是距离、第二列是高程、第三列是淤泥线数据，淤泥线数据的第一行有三个选项：无、高程、高差。
没有淤泥线数据时为无；
淤泥线数据是淤泥底的高程时选高程；
淤泥线数据是相对于剖面线的高差时选高差，剖面线在淤泥底时高差为正、剖面线在淤泥顶时高差为负。
淤泥线数据头尾只有一个0
下图是叠加淤泥线的剖面图，红色线是剖面线，填充图案是淤泥的截面积。
其中：H 二个桩号间的长度
S1 前一条剖面的淤泥截面积
S2 后一条剖面的淤泥截面积
剖面绘制Form：
Dim 网格线间隔 As Integer, 引线长度 As BooleanDim 过滤器 As String, path As String, 定位 As StringDim 块名 As StringDim 剖面线(), 线数 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()引线长度 = TrueEnd Sub Private Sub OptionButton6_Click()引线长度 = FalseEnd Sub Private Sub OptionButton4_Click()网格线间隔 = -100End Sub Private Sub OptionButton7_Click()网格线间隔 = 2End Sub Private Sub OptionButton8_Click()网格线间隔 = 5End Sub Private Sub OptionButton9_Click()网格线间隔 = 10End Sub Private Sub UserForm_Initialize()ThisDrawing.SendCommand "_-purge" + vbCr + "a" + vbCr + vbCr + "n" + vbCr '清块网格线间隔 = 10引线长度 = True定位 = "中心定位"End SubPrivate Sub CheckBox4_Click()Dim mm As StringIf CheckBox4.value <> True Then Exit SubPmFile0.Text = GetOpenFile("查找数轴格式剖面数据文件", "文本文件 Files(*.txt), Profile.hdm", path)If PmFile0.Text = PmFile.Text Then MsgBox "二个剖面文件是同一个，无法完成绘制！" CheckBox4.value = False Exit SubEnd IfIf Dir(PmFile0.Text) = "" Then MsgBox "初测剖面文件不存在，无法完成绘制！" CheckBox4.value = False Exit SubEnd If'读入要叠加的旧剖面线数据线数 = -1Call AddLayer("剖面线0", 2)Open PmFile0.Text For Input As #2While Not (EOF(2)) Line Input #2, mm Line Input #2, mm pl = 长字符串转实数数组(mm) 线数 = 线数 + 1 ReDim Preserve 剖面线(1, 线数) 剖面线(0, 线数) = (UBound(pl) - 1) / 2 剖面线(1, 线数) = plWendCloseEnd Sub Private Sub 标准文件_Click()Dim nL As Integer, N As Integer, i As IntegerDim 剖面名称 As String, mm As StringDim Ixy(0 To 2) As DoubleDim H小 As Double, H大 As Double, H水 As Double, 水面高程 As DoubleDim 左线长 As Double, 右线长 As DoubleDim 总线长 As Double, 线长 As DoubleDim sL As Double, sR As DoubleDim 行 As Integer, 行高 As Double, 控制行数 As IntegerDim 列 As Integer, 列宽 As DoubleDim strm(0 To 1) As Double, JiuPm() As DoubleDim blockObj As AcadBlockReferenceDim 左边距离 As DoubleDim 前缀 As StringDim PmFile As StringOn Error Resume NextPmFile = 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: 总线长 = 0Open PmFile For Input As #1While 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大) NextWendCloseH小 = Int(H小) - 2 '剖面原点的高程值H大 = 2 + Int(H大) Dim ptL(0 To 2) As Double, ptR(0 To 2) As DoubleSelect 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 = -1Dim 纵剖面() As DoubleOpen PmFile For Input As #1While 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 IfWendClose线长 = 纵剖面(nL * 2)总线长 = 总线长 + 线长Ixy(0) = IIf(定位 = "中心定位", 10000 - 10 * Int(左线长 + 1), 10000) '插入点从中心移到左侧Ixy(1) = 20150 + 10 * (H大 - H小) ptL(0) = 0ptL(1) = 0ptR(0) = 10 * Int(线长 + 1)ptR(1) = 10 * (H大 - H小) Call 纵剖面画线(纵剖面, Ixy, ptL, ptR, H大, H小) xy1(0) = Ixy(0) + (ptR(0) - ptL(0)) / 2 - 60xy1(1) = Ixy(1) + 10 * (H大 - H小) + 60mm = "共绘制横剖面： " + str(nL + 1) + " 条；纵剖面 1 条。剖面线总长度= " + Format(总线长, "0.00") + "米。"Call AddText(mm, xy1, 20, "坐标系") ThisDrawing.Application.ZoomExtentsThisDrawing.Regen acActiveViewportMsgBox "恭喜你，完成啦！"Unload MeEnd Sub Private Sub Excel文件_Click()Dim nL As Integer, N As Integer, i As IntegerDim 剖面名称 As String, mm As StringDim Ixy(0 To 2) As DoubleDim H小 As Double, H大 As Double, H水 As Double, 水面高程 As DoubleDim 左线长 As Double, 右线长 As DoubleDim 总线长 As Double, 线长 As DoubleDim sL As Double, sR As DoubleDim 行 As Integer, 行高 As Double, 控制行数 As IntegerDim 列 As Integer, 列宽 As DoubleDim JiuPm() As DoubleDim blockObj As AcadBlockReferenceDim 淤泥点() As Double, 淤泥点数 As IntegerDim 左边距离 As DoubleDim ynArea() As Variant, 淤泥量 As DoubleDim 前缀 As StringDim 纵剖面() As DoubleDim PmFile As StringOn Error Resume Next前缀 = 桩号前缀PmFile = GetOpenFile("查找剖面数据(Excel文件)", "剖面数据文件(*.xls)" & vbNullChar & "*.xlsx", path)If Dir(PmFile) = "" Then Exit SubThisDrawing.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: 总线长 = 0Workbooks.Open FileName:=PmFile '打开文件With ActiveWorkbook.Sheets("横剖面")N = 1Do 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 + 3LoopH小 = Int(H小) - 2 '剖面原点的高程值H大 = 2 + Int(H大) Dim ptL(0 To 2) As Double, ptR(0 To 2) As DoubleSelect 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 = 1nL = -1Dim 间隔 As DoubleDo 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 + 3LoopEnd 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 = 1Do 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 + 1LoopEnd With 线长 = 纵剖面(nL * 2)总线长 = 总线长 + 线长 Ixy(0) = IIf(定位 = "中心定位", 10000 - 10 * Int(左线长 + 1), 10000) '插入点从中心移到左侧Ixy(1) = 20150 + 10 * (H大 - H小)ptL(0) = 0ptL(1) = 0ptR(0) = 10 * Int(线长 + 1)ptR(1) = 10 * (H大 - H小)Call 纵剖面画线(纵剖面, Ixy, ptL, ptR, H大, H小) xy1(0) = Ixy(0) + (ptR(0) - ptL(0)) / 2 - 60xy1(1) = Ixy(1) + 10 * (H大 - H小) + 60mm = "共绘制横剖面： " + str(nL + 1) + " 条；纵剖面 1 条。剖面线总长度= " + Format(总线长, "0.00") + "米。"Call AddText(mm, xy1, 20, "坐标系")ActiveWorkbook.CloseThisDrawing.Application.ZoomExtentsThisDrawing.Regen acActiveViewportDim ybFile As String, FileName As StringybFile = VBApath & "相关文件\淤泥量计算表.xlsx"FileName = ThisDrawing.path & "\淤泥量计算表.xlsx"If Dir(FileName) = "" Then FileCopy ybFile, FileNameEnd IfWorkbooks.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") NextEnd WithActiveWorkbook.Close (True) MsgBox "恭喜你，完成啦！"Unload MeEnd Sub
免责声明：本文系网络转载或改编，未找到原创作者，版权归原作者所有。如涉及版权，请联系删
技术文档
热门文章
155-2731-8020
