剖面测量之剖面绘制

剖面及土方测量是较常见的工程测量项目，早期剖面测量采用的经纬仪导线放线，测量地形变换点的高程，现在使用 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