沙漠骆驼工具箱源码-15重生成纵断面

woxing1987

工具条 ：重生成纵断面1 界面





2 代码如下


    Dim oldyscale As Double '设置老的垂直比例
    Dim oldxscale As Double '定义老的x方向比例
    Dim zigao As Single   '字体高度
    Dim xscale As Double    '定义x方向比例
    Dim yscale As Double   '设置垂直比例
    Dim dimianxian As AcadLWPolyline   '定义原地面线
    Dim dmxzdm As AcadLWPolyline   '定义新的地面线
    Dim qitadmxzdm As AcadLWPolyline '定义其他地面线
    Dim qitaxian() As AcadLWPolyline   '用于存储其他纵断面线
    Dim qitaxiancount As Double
    Dim basepoint As Variant '定义插入点
    Dim gcbasepoint As Variant '定义高程基准点
    Dim maxgc As Double     '设置最大高程
    Dim mingc As Double     '设置最小高程
    Dim ccmaxgc As Double '用于存储比地面线高出的高程值，有时候其他纵断面比原始的地面线要高
    Dim ccmingc As Double '用于存储比地面线低出的高程值，有时候其他纵断面比原始的地面线要低

    Dim dy As Integer      '设置间隔距离，单位为m
    Dim dx As Double       '设置水平间隔距离，单位为m
    Dim ndy As Integer    '设置标尺干最下面多出的距离为 n*dy
    Dim jizhungc As Double    '定义基准高程
    Dim changdu As Double     '定义地面线的长度，x方向的距离，即桩号
    Dim qidiangaocheng As Double '定义新的地面线起始点高程
    Dim zuoxiadian As Variant
    Dim youshangdian As Variant

    Dim biaochiganlayer As AcadLayer '定义标尺杆图层
    Dim shujulanlayer  As AcadLayer '定义数据栏图层
    Dim zongduanmianlyer As AcadLayer '定义地面线和其他纵断面图层
    Dim currentlayername As String
    Dim currenttextstyle As String

Private Sub ComboBox1_Change()
    CommandButton2.Enabled = False
    CommandButton3.Enabled = False
End Sub

Private Sub ComboBox2_Change()
    CommandButton2.Enabled = False
    CommandButton3.Enabled = False
End Sub

Private Sub CommandButton1_Click() '获取基准高程
    Me.Hide
    On Error Resume Next
    quxiao '调用取消命令
    gcbasepoint = ThisDrawing.Utility.GetPoint(, "请拾取高程基准点(准确的高程值):")
    jizhungc = ThisDrawing.Utility.GetReal("请输入高程基准：")
'    If Err Then
'        ThisDrawing.Utility.prompt "-----高程基准输入错误，请重新操作------" & vbCrLf
'        Me.show
'        Err.Clear
'        CommandButton2.Enabled = False
'        Exit Sub
'    End If
    Me.show
    CommandButton2.Enabled = True
    CommandButton3.Enabled = False
End Sub
Private Sub CommandButton2_Click() '选取地面线及其他多段线
    Me.Hide
    oldyscale = ComboBox1.Text
    oldxscale = ComboBox2.Text

    On Error Resume Next
    quxiao '调用取消命令
    ThisDrawing.Utility.GetEntity dimianxian, basepoint, "拾取地面线:"
'    If Err Then
'        ThisDrawing.Utility.prompt "-----地面线获取失败，请重新操作------" & vbCrLf
'        Me.show
'        Err.Clear
'        CommandButton3.Enabled = False
'        Exit Sub
'    End If
    CommandButton3.Enabled = True
    dimianxian.Visible = False
    Dim zuoxiapoint As Variant '定义临时的getboundingbox 的存储点
    Dim youshangpoint As Variant
    dimianxian.GetBoundingBox zuoxiapoint, youshangpoint

    '计算断面线长度，换成米。实际长度是不变的，也就是桩号值是不变的
    changdu = Abs((youshangpoint(0) - zuoxiapoint(0)) * oldxscale / 1000)
    'MsgBox changdu
    Dim filtertype(0) As Integer '定义选择过滤器类型的dsf组码， 动态数组
    Dim filterdata(0) As Variant '定义过滤器的值，为动态数组
'    ReDim filtertype(3)
'    ReDim filterdata(3)
    filtertype(0) = 0
    filterdata(0) = "lwpolyline"
    Dim sset1 As AcadSelectionSet
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选其他多段线:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        Me.show
        dimianxian.Visible = True
        qitaxiancount = -1
        Exit Sub
    End If
    dimianxian.Visible = True
    qitaxiancount = sset1.count - 1
    ReDim qitaxian(qitaxiancount)
    Dim i As Integer
    For i = 0 To qitaxiancount
        Set qitaxian(i) = sset1.Item(i)
'        MsgBox qitaxian(i).ObjectName
    Next

    '求最大高程和最小高程,用于移动其他地面线，也为标尺干提供最大和最小高程
    Dim ccbox1 As Variant
    Dim ccbox2 As Variant
    Dim ccbox3 As Variant
    Dim ccbox4 As Variant
    dimianxian.GetBoundingBox ccbox3, ccbox4
    If qitaxiancount >= 0 Then
        Dim ii As Double
        Dim zuida As Double
        Dim zuixiao As Double
        zuida = 0
        zuixiao = 0
        For ii = 0 To qitaxiancount
            qitaxian(ii).GetBoundingBox ccbox1, ccbox2
            ccmaxgc = ccbox2(1) - ccbox4(1)
            ccmingc = ccbox3(1) - ccbox1(1)
            If ccmaxgc >= 0 Then
                ccmaxgc = Int(ccmaxgc * oldyscale / 1000) + 1
            End If
            If ccmingc >= 0 Then
                ccmingc = Int(ccmingc * oldyscale / 1000) + 1
            End If
            If ccmaxgc > zuida Then zuida = ccmaxgc
            If ccmingc > zuixiao Then zuixiao = ccmingc
        Next
        ccmaxgc = zuida + 1
        ccmingc = zuixiao + 1
    End If
    Me.show
End Sub

Private Sub CommandButton3_Click() '拾取插入位置
    Me.Hide
    On Error Resume Next
    quxiao '调用取消命令
    zigao = ComboBox3.Text
    yscale = ComboBox4.Text
    xscale = ComboBox5.Text
    dy = Left(ComboBox6.Text, 2)
    dx = ComboBox7.Text
    ndy = ComboBox8.Text
    oldyscale = ComboBox1.Text
    oldxscale = ComboBox2.Text

    currentlayername = ThisDrawing.ActiveLayer.name
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    ThisDrawing.SetVariable "textstyle", "wh_lkx"

    basepoint = ThisDrawing.Utility.GetPoint(, "拾取插入点位置:")
'    If Err Then
'        ThisDrawing.Utility.prompt "-----拾取点错误，请重新操作------" & vbCrLf
'        Me.show
'        Err.Clear
'        Exit Sub
'    End If

    '1画地面线及其他有关的多段线
    huadimianxian basepoint, dimianxian
    If qitaxiancount >= 0 Then
        Dim ii As Double
        For ii = 0 To qitaxiancount
            huaqitaxian basepoint, qitaxian(ii), dimianxian '画 其他有关的多段线
        Next
    End If

    '2画标尺杆有点问题，高程对不上，以后有时间在解决 现在解觉了
    huabiaochigan basepoint  ', mingc, maxgc, yscale, zigao, dy

    '3画数据栏
    shujulan basepoint, dmxzdm, changdu  ', zigao, xscale, mingc

    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername) '恢复图层
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    Me.show
End Sub

Private Sub CommandButton4_Click()
    Me.Hide
End Sub


'1-1画地面线
Private Sub huadimianxian(point As Variant, zdmxian As AcadLWPolyline) 'zdmxian 为原地面线
'    Set zongduanmianlyer = ThisDrawing.Layers.Add("地面线")
'    ThisDrawing.ActiveLayer = zongduanmianlyer
    Dim zdmdingdian As Variant
    zdmdingdian = zdmxian.Coordinates
'    Dim min As Double
'    min = Int(mingc) - dy * 2
    Dim count As Double

    count = UBound(zdmdingdian)
    ReDim bakjuligaocheng(count) As Double  '新建一个数组，原数组不动，因为数组是按地址(byref)传递的,

    '使其起点也在原点上，'然后，x ,y方向再放大相应的倍数，
    ' '以实现x ,y方向不同比例的缩放  最后在移到原起始坐标上
    Dim i As Double
    For i = 0 To count \ 2
        bakjuligaocheng(2 * i) = zdmdingdian(2 * i) - zdmdingdian(0)
        bakjuligaocheng(2 * i + 1) = zdmdingdian(2 * i + 1) - zdmdingdian(1)
    Next
    For i = 0 To count \ 2
        bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) * (oldxscale / xscale)
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) * (oldyscale / yscale)
        'bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + ((movevalue - min) * yscale / 1000) * (oldyscale / yscale)
        bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) + point(0)
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + point(1)
    Next
    '画新的地面线
    Set dmxzdm = ThisDrawing.ModelSpace.AddLightWeightPolyline(bakjuligaocheng)
    dmxzdm.ConstantWidth = 0.1

    With dmxzdm
            .Linetype = zdmxian.Linetype
            .Layer = zdmxian.Layer
            .LinetypeScale = zdmxian.LinetypeScale
            .Lineweight = zdmxian.Lineweight
            .ConstantWidth = zdmxian.ConstantWidth
            .LinetypeGeneration = zdmxian.LinetypeGeneration
            .color = zdmxian.color
    End With

    '求最大高程和最小高程，以便后面画标尺杆和数据栏用，求高程用
    dmxzdm.GetBoundingBox zuoxiadian, youshangdian
    maxgc = youshangdian(1)
    mingc = zuoxiadian(1)

    ' qidiangaocheng  为新的地面线起始点高程
    qidiangaocheng = jizhungc + (zdmdingdian(1) - gcbasepoint(1)) * oldyscale / 1000

    'If maxgc = Int(maxgc) Then max = Int(maxgc) Else max = Int(maxgc) + 1
    maxgc = Int(qidiangaocheng + (maxgc - bakjuligaocheng(1)) * yscale / 1000)
    mingc = Int(qidiangaocheng + (mingc - bakjuligaocheng(1)) * yscale / 1000) - dy * ndy

    maxgc = maxgc + ccmaxgc
    mingc = mingc - ccmingc
    '下面移动新的地面线
    'MsgBox qidiangaocheng
    'MsgBox mingc
    Dim movedmx(0 To 2) As Double
    movedmx(0) = basepoint(0)
    movedmx(1) = basepoint(1) + (qidiangaocheng - mingc) * 1000 / yscale
    dmxzdm.Move basepoint, movedmx
End Sub


'1-2画其他纵断面线
Private Sub huaqitaxian(point As Variant, zdmxian As AcadLWPolyline, dimianxian As AcadLWPolyline)
    'zdmxian 为原来的其他线，dimianxian为原始的地面线
'    Set zongduanmianlyer = ThisDrawing.Layers.Add("地面线")
'    ThisDrawing.ActiveLayer = zongduanmianlyer
    Dim zdmdingdian As Variant
    zdmdingdian = zdmxian.Coordinates

    Dim count As Double
    count = UBound(zdmdingdian)
    ReDim bakjuligaocheng(count) As Double  '新建一个数组，原数组不动，因为数组是按地址(byref)传递的,

    '使其起点也在原点上，'然后，x ,y方向再放大相应的倍数，
    ' '以实现x ,y方向不同比例的缩放  最后在移到原起始坐标上
    '获取其他线相对于原地面线的位置

    Dim i As Double
    For i = 0 To count \ 2
        bakjuligaocheng(2 * i) = zdmdingdian(2 * i) - zdmdingdian(0)
        bakjuligaocheng(2 * i + 1) = zdmdingdian(2 * i + 1) - zdmdingdian(1)
        'MsgBox bakjuligaocheng(2 * i)
    Next
    For i = 0 To count \ 2
        bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) * (oldxscale / xscale)
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) * (oldyscale / yscale)
        bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) + point(0)
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + point(1)
    Next

    Set qitadmxzdm = ThisDrawing.ModelSpace.AddLightWeightPolyline(bakjuligaocheng)
    'MsgBox zdmxian.ConstantWidth
    With qitadmxzdm
            .Linetype = zdmxian.Linetype
            .Layer = zdmxian.Layer
            .LinetypeScale = zdmxian.LinetypeScale
            .Lineweight = zdmxian.Lineweight
            .ConstantWidth = zdmxian.ConstantWidth
            .LinetypeGeneration = zdmxian.LinetypeGeneration
            .color = zdmxian.color
    End With
    'MsgBox qitadmxzdm.ConstantWidth
    '下面进行移动其他的地面线
    Dim qidian1 As Variant
    Dim qidian2  As Variant
    qidian1 = zdmxian.Coordinate(0) ' zdmxian 是原来的其他地面线，
    qidian2 = dimianxian.Coordinate(0) ' dimianxian 是原来的地面线，

    Dim movept(0 To 2) As Double
    Dim movept1(0 To 2) As Double
    movept(0) = basepoint(0)
    movept(1) = basepoint(1) + (qidiangaocheng - mingc) * 1000 / yscale
    qitadmxzdm.Move point, movept '移动到新的地面线的起始点上
    movept1(0) = movept(0) + (qidian1(0) - qidian2(0)) * oldxscale / xscale
    movept1(1) = movept(1) + (qidian1(1) - qidian2(1)) * oldyscale / yscale
    qitadmxzdm.Move movept, movept1
End Sub

'2画左标尺杆
Private Sub huabiaochigan(point As Variant)
', mingc As Double, maxgc As Double, yscale As Double, zigao As Single, dy As Integer)
    '根据最大和最小高程的差值范围来自动确定间隔距离
    '根据最大和最小高程的差值范围来自动确定间隔距离
    Set biaochiganlayer = ThisDrawing.Layers.Add("标尺杆")
    ThisDrawing.ActiveLayer = biaochiganlayer
    biaochiganlayer.color = acGreen
    ThisDrawing.SetVariable "cecolor", "256" '设置为bylayer
    Dim max As Double
    Dim min As Double
    'If maxgc = Int(maxgc) Then max = Int(maxgc) Else max = Int(maxgc) + 1
    'min = Int(mingc) - dy * 2
    max = maxgc + 1
    'MsgBox max
    min = mingc
    Dim h As Double
    h = max - min
    If dy = 2 Then If h Mod 2 <> 0 Then h = h + 1
    If dy = 5 Then If h Mod 5 <> 0 Then h = h - h Mod 5 + 5
    If dy = 10 Then If h Mod 10 <> 0 Then h = h - h Mod 10 + 10
    If dy = 20 Then If h Mod 20 <> 0 Then h = h - h Mod 20 + 20
    If dy = 25 Then If h Mod 25 <> 0 Then h = h - h Mod 25 + 25
    If dy = 40 Then If h Mod 40 <> 0 Then h = h - h Mod 40 + 40
    If dy = 50 Then If h Mod 50 <> 0 Then h = h - h Mod 50 + 50
    Dim pline1 As AcadLWPolyline
    Dim p1(0 To 9) As Double
    p1(0) = point(0): p1(1) = point(1)
    p1(2) = p1(0): p1(3) = p1(1) + h * 1000 / yscale
    p1(4) = p1(0) - 1.5: p1(5) = p1(3)
    p1(6) = p1(0) - 1.5: p1(7) = p1(1)
    p1(8) = p1(0): p1(9) = p1(1)
    Set pline1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)
    Dim i As Double
    Dim pt(0 To 3) As Double '多段线起点终点坐标
    Dim pline2 As AcadLWPolyline '多段线填充，宽度为1.5
    Dim textobj As AcadText
    Dim textpoint(0 To 2) As Double  '高程文字插入点
    textpoint(0) = p1(0) - 2.75: textpoint(1) = p1(1)  '最下边的高程
    Set textobj = ThisDrawing.ModelSpace.AddText(min, textpoint, zigao)
    With textobj
        .Alignment = acAlignmentRight
        .TextAlignmentPoint = textpoint
    End With
    For i = 1 To h \ dy \ 2
        pt(0) = p1(0) - 0.75: pt(1) = p1(1) + (2 * i - 1) * dy * 1000 / yscale '多段线起点坐标
        pt(2) = pt(0): pt(3) = p1(1) + 2 * i * dy * 1000 / yscale
        Set pline2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
        pline2.SetWidth 0, 1.5, 1.5
        textpoint(0) = pt(0) - 2: textpoint(1) = pt(1)
        Set textobj = ThisDrawing.ModelSpace.AddText(min + (2 * i - 1) * dy, textpoint, zigao)
        With textobj
            .Alignment = acAlignmentMiddleRight
            .TextAlignmentPoint = textpoint
        End With
        If i = h / dy / 2 Then Exit For '取消标尺杆最上边的高程数据
        textpoint(0) = pt(2) - 2: textpoint(1) = pt(3)
        Set textobj = ThisDrawing.ModelSpace.AddText(min + 2 * i * dy, textpoint, zigao)
        With textobj
            .Alignment = acAlignmentMiddleRight
            .TextAlignmentPoint = textpoint
        End With
    Next
    textpoint(0) = p1(0) - 2.75: textpoint(1) = p1(3)  '最上边的高程文字：高程(m)
    Set textobj = ThisDrawing.ModelSpace.AddText("高程(m)", textpoint, zigao)
    With textobj
        .Alignment = acAlignmentTopRight
        .TextAlignmentPoint = textpoint
    End With

    '下面添加标题名称 ，比例尺，和桩号距离
    'Set biaotilayer = ThisDrawing.Layers.Add("标题文字")
    '由于地面线移动了，重新获取boundingbox
    Dim biaotitext As AcadText
    textpoint(0) = textpoint(0)
    textpoint(1) = textpoint(1) + 15
    Set biaotitext = ThisDrawing.ModelSpace.AddText("水平 1:" & xscale, textpoint, 4)
    textpoint(1) = textpoint(1) - 6
    Set biaotitext = ThisDrawing.ModelSpace.AddText("垂直 1:" & yscale, textpoint, 4)
    textpoint(0) = textpoint(0) - 11
    textpoint(1) = textpoint(1) + 3
    Set biaotitext = ThisDrawing.ModelSpace.AddText("比例 ", textpoint, 4)
End Sub


'3 画数据栏
Private Sub shujulan(point As Variant, dmxpline As AcadLWPolyline, length As Double)
', zigao As Single, xscale As Double, mingc As Double)
    Set shujulanlayer = ThisDrawing.Layers.Add("数据栏")
    ThisDrawing.ActiveLayer = shujulanlayer
    shujulanlayer.color = acCyan
    ThisDrawing.SetVariable "cecolor", "256"
    Dim pt() As Double  '动态数组
    Dim plineobj As AcadLWPolyline
    Dim textobj As AcadText
    Dim textpoint(0 To 2) As Double '定义文字对起点
    ReDim pt(0 To 7)
    pt(0) = point(0): pt(1) = point(1)
    pt(2) = pt(0) - 25: pt(3) = pt(1)
    pt(4) = pt(2): pt(5) = pt(3) - 28
    pt(6) = pt(0): pt(7) = pt(5)
    Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    plineobj.Closed = True
    ReDim pt(0 To 3)
    pt(0) = point(0): pt(1) = point(1) - 14
    pt(2) = pt(0) - 25: pt(3) = pt(1)
    Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    textpoint(0) = point(0) - 12.5: textpoint(1) = point(1) - 7
    Set textobj = ThisDrawing.ModelSpace.AddText("距 离(m)", textpoint, zigao)
    textobj.Alignment = acAlignmentMiddleCenter
    textobj.TextAlignmentPoint = textpoint
    textpoint(1) = point(0) - 12.5: textpoint(1) = point(1) - 21
    Set textobj = ThisDrawing.ModelSpace.AddText("高 程(m)", textpoint, zigao)
    textobj.Alignment = acAlignmentMiddleCenter
    textobj.TextAlignmentPoint = textpoint
    ReDim pt(0 To 7)
    pt(0) = point(0): pt(1) = point(1)
    pt(2) = pt(0) + length * 1000 / xscale: pt(3) = pt(1)
    pt(4) = pt(2): pt(5) = pt(3) - 28
    pt(6) = pt(0): pt(7) = pt(5)
    Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    ReDim pt(0 To 3)
    pt(0) = point(0): pt(1) = point(1) - 14
    pt(2) = pt(0) + length * 1000 / xscale: pt(3) = pt(1)
    Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)

    '下面向数据栏里添加距离 高程数据
    Dim min As Double
    'min = Int(mingc) - dy * 2
    min = mingc
    'MsgBox min
    Dim zhuanghao As Double     '桩号 数据
    Dim gaocheng As Double      '高程 数据 ，交点y坐标
    Dim zhjltext As AcadText    '桩号，高程文字
                                         '----------------------------'第一个桩号0+000                |
    zhuanghao = 0
    Dim dyg(0 To 3) As Double '画一个小短线，以便求交点
    dyg(0) = point(0): dyg(1) = point(1)
    dyg(2) = point(0): dyg(3) = point(1) + 2
    Dim dygpline As AcadLWPolyline
    Set dygpline = ThisDrawing.ModelSpace.AddLightWeightPolyline(dyg)
    gaocheng = dygpline.IntersectWith(dmxpline, acExtendBoth)(1)  '求交点，以获得高程值
   'MsgBox gaocheng
    'MsgBox point(1)
    gaocheng = (gaocheng - point(1)) * yscale / 1000 + min

    dygpline.Delete
    textpoint(0) = point(0): textpoint(1) = point(1) - 7
    Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000"), textpoint, zigao)     '|
        zhjltext.Alignment = acAlignmentTopCenter                                                   '|添
        zhjltext.TextAlignmentPoint = textpoint                                                     '|
        zhjltext.Rotation = 3.1415926 / 2
    textpoint(1) = point(1) - 21                           '第一个高程值
    Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
        zhjltext.Alignment = acAlignmentTopCenter                                                   '|
        zhjltext.TextAlignmentPoint = textpoint                                                     '|
        zhjltext.Rotation = 3.1415926 / 2                                                           '|加
    zhuanghao = dx                                                                                  '|
    Do While zhuanghao < length    '循环添加桩号和高程                                               '|桩
        textpoint(0) = textpoint(0) + dx * 1000 / xscale: textpoint(1) = point(1) - 7               '|
        Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000"), textpoint, zigao) '|号
            zhjltext.Alignment = acAlignmentBottomCenter                                            '|
            zhjltext.TextAlignmentPoint = textpoint                                                 '|
            zhjltext.Rotation = 3.1415926 / 2                                                       '|和
        pt(0) = textpoint(0): pt(1) = point(1)
        pt(2) = textpoint(0): pt(3) = point(1) - 28
        Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
        gaocheng = plineobj.IntersectWith(dmxpline, acExtendBoth)(1)  '求交点，以获得高程值
        gaocheng = (gaocheng - point(1)) * yscale / 1000 + min
        textpoint(1) = point(1) - 21
        Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
            zhjltext.Alignment = acAlignmentBottomCenter                                            '|高
            zhjltext.TextAlignmentPoint = textpoint                                                 '|
            zhjltext.Rotation = 3.1415926 / 2
        zhuanghao = zhuanghao + dx
    Loop                                                                                            '|
    textpoint(0) = point(0) + length * 1000 / xscale: textpoint(1) = point(1) - 7   '最后一个桩号    '|
    Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(length, "0+000.00"), textpoint, zigao)     '|程
        zhjltext.Alignment = acAlignmentBottomCenter                                                '|
        zhjltext.TextAlignmentPoint = textpoint                                                     '|
        zhjltext.Rotation = 3.1415926 / 2                                                           '|
    pt(0) = textpoint(0): pt(1) = point(1)
    pt(2) = textpoint(0): pt(3) = point(1) - 28
    Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    gaocheng = plineobj.IntersectWith(dmxpline, acExtendBoth)(1)            '最后一个桩号
    gaocheng = (gaocheng - point(1)) * yscale / 1000 + min
    textpoint(1) = point(1) - 21
    Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
        zhjltext.Alignment = acAlignmentBottomCenter                                               '|
        zhjltext.TextAlignmentPoint = textpoint                                                    '|
        zhjltext.Rotation = 3.1415926 / 2
                                                             '----------------------------------- --|
End Sub

Private Sub UserForm_Initialize()
    '原纵断面数据
    Dim i As Integer
    ComboBox1.AddItem 1
    ComboBox1.AddItem 2
    ComboBox1.AddItem 5
    ComboBox1.AddItem 10 '设置垂直比例
    ComboBox1.AddItem 20
    ComboBox1.AddItem 25
    ComboBox1.AddItem 50
    For i = 3 To 6
        ComboBox1.AddItem 10 * ComboBox1.List(i)
    Next
    For i = 3 To 6
        ComboBox1.AddItem 100 * ComboBox1.List(i)
    Next
    For i = 3 To 6
        ComboBox1.AddItem 1000 * ComboBox1.List(i)
    Next
    ComboBox1.AddItem 300

    ComboBox2.AddItem 1  '设置水平比例
    ComboBox2.AddItem 2
    ComboBox2.AddItem 5
    ComboBox2.AddItem 10
    ComboBox2.AddItem 20
    ComboBox2.AddItem 25
    ComboBox2.AddItem 50
    For i = 3 To 6
        ComboBox2.AddItem 10 * ComboBox2.List(i)
    Next
    For i = 3 To 6
        ComboBox2.AddItem 100 * ComboBox2.List(i)
    Next
    For i = 3 To 6
        ComboBox2.AddItem 1000 * ComboBox2.List(i)
    Next

    '新纵断面数据
    For i = 1 To 9  '设置字体高度
        ComboBox3.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    ComboBox4.AddItem 1
    ComboBox4.AddItem 2
    ComboBox4.AddItem 5
    ComboBox4.AddItem 10 '设置垂直比例
    ComboBox4.AddItem 20
    ComboBox4.AddItem 25
    ComboBox4.AddItem 50
    For i = 3 To 6
        ComboBox4.AddItem 10 * ComboBox4.List(i)
    Next
    For i = 3 To 6
        ComboBox4.AddItem 100 * ComboBox4.List(i)
    Next
    For i = 3 To 6
        ComboBox4.AddItem 1000 * ComboBox4.List(i)
    Next
    ComboBox4.AddItem 300

    ComboBox5.AddItem 1   '设置水平比例
    ComboBox5.AddItem 2
    ComboBox5.AddItem 5
    ComboBox5.AddItem 10
    ComboBox5.AddItem 20
    ComboBox5.AddItem 25
    ComboBox5.AddItem 50
    For i = 3 To 6
        ComboBox5.AddItem 10 * ComboBox5.List(i)
    Next
    For i = 3 To 6
        ComboBox5.AddItem 100 * ComboBox5.List(i)
    Next
    For i = 3 To 6
        ComboBox5.AddItem 1000 * ComboBox5.List(i)
    Next

    ComboBox6.AddItem "01m" '设置高程间隔
    ComboBox6.AddItem "02m"
    ComboBox6.AddItem "05m"
    ComboBox6.AddItem "10m"
    ComboBox6.AddItem "20m"
    ComboBox6.AddItem "25m"
    ComboBox6.AddItem "40m"
    ComboBox6.AddItem "50m"

    '设置桩号间距
    ComboBox7.AddItem 5
    ComboBox7.AddItem 10
    ComboBox7.AddItem 20
    ComboBox7.AddItem 25
    For i = 0 To 3
        ComboBox7.AddItem 10 * ComboBox7.List(i)
    Next
    For i = 0 To 3
        ComboBox7.AddItem 100 * ComboBox7.List(i)
    Next

    '设置标尺干的超出长度，为 n * dy
    For i = 1 To 10
        ComboBox8.AddItem i
    Next

    newtextstyle2 '调用新建字体样式程序
End Sub

' '创建新的字体样式
'Private Sub newtextstyle()   '创建新的字体样式
'    Dim typeFace As String
'    Dim SavetypeFace As String
'    Dim Bold As Boolean
'    Dim Italic As Boolean
'    Dim charSet As Long
'    Dim PitchandFamily As Long
'    Dim lkxtextstyle As AcadTextStyle
'    Dim currenttextstyle As AcadTextStyle
'    Set currenttextstyle = ThisDrawing.ActiveTextStyle
'    '获取当前字体样式的参数
'    currenttextstyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
'    Set lkxtextstyle = ThisDrawing.TextStyles.Add("wh_lkx")
'    With lkxtextstyle
'        .SetFont "宋体", False, False, charSet, PitchandFamily
'        .width = 0.8   '设置宽度比例
'    End With
'End Sub