沙漠骆驼工具箱源码-16纵断面图分幅

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 qitaxian() As AcadLWPolyline   '用于存储其他纵断面线
    Dim dmxzdm As AcadLWPolyline   '定义新的地面线
    Dim qitadmxzdm 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 yuanjizhungaocheng As Double    '定义原基准高程
    Dim xinjizhungaocheng 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

    Dim fenfugeshu As Integer     '分幅个数
    Dim fenfuchangdu As Double    '分幅长度
    Dim suoyouzuobiao As Variant  '用于存储地面线及其他线的所有坐标
    Dim fenduanzuobiao() As Double    '用于存储地面线每段的坐标，为动态数组
    Dim fenduanzuobiao1() As Double   '用于存储其他线每段的坐标，为动态数组

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(, "请拾取高程基准点(准确的高程值):")
    If Err Then
        ThisDrawing.Utility.prompt "-----拾取基准点获取错误，请重新操作------" & vbCrLf
        Me.show
        Err.Clear
        Exit Sub
    End If
    yuanjizhungaocheng = 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
    On Error Resume Next
    quxiao '调用取消命令
    oldyscale = ComboBox1.Text
    oldxscale = ComboBox2.Text

    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)
    fenfuchangdu = ComboBox9.Text
    fenfugeshu = changdu \ fenfuchangdu
    '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
    fenfuchangdu = ComboBox9.Text
    fenfugeshu = changdu \ fenfuchangdu

    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
    Dim i As Integer
    Dim k As Integer
    Dim qidian(0 To 2) As Double
    qidian(0) = basepoint(0)
    qidian(1) = basepoint(1)
    Dim shuline1 As AcadLine  '画竖线，用于求交点
    Dim shuline2 As AcadLine
    Dim ppp1(0 To 2) As Double    '画直线用的
    Dim ppp2(0 To 2) As Double '画直线用的
    Dim jiaodian1 As Variant '定义分幅起始点
    Dim jiaodian2 As Variant '定义分幅的末点
    Dim yidongpt1(0 To 2) As Double '定义移动点1
    Dim yidongpt2(0 To 2) As Double '定义移动点2
    'suoyouzuobiao = dimianxian.Coordinates
    If fenfugeshu = 0 Then
        MsgBox "分幅个数太少！请重新选择分幅长度。", vbCritical, "分幅"
        Me.show
        Exit Sub
    End If
    'MsgBox fenfugeshu
    '用来画线求交点，用于分幅
    Dim xiangduidian(0 To 2) As Double '定义标尺干和数据栏的交点，即相对坐标原点

    ppp1(0) = dimianxian.Coordinate(0)(0)
    ppp1(1) = dimianxian.Coordinate(0)(1)
    ppp2(0) = ppp1(0)
    ppp2(1) = ppp1(1) + 10
    '

    Dim ccbox1 As Variant
    Dim ccbox2 As Variant
    Dim ccbox3 As Variant
    Dim ccbox4 As Variant
    '开始分幅
    For i = 0 To fenfugeshu - 1
        '下面求出每一段的地面线包含的坐标值，用于后面画分幅断面使用
        'MsgBox dierdian(0)
        Set shuline1 = ThisDrawing.ModelSpace.AddLine(ppp1, ppp2)
        ppp1(0) = ppp1(0) + fenfuchangdu * 1000# / oldxscale
        ppp2(0) = ppp1(0)
        ppp2(1) = ppp1(1) + 10
        Set shuline2 = ThisDrawing.ModelSpace.AddLine(ppp1, ppp2)
        jiaodian1 = dimianxian.IntersectWith(shuline1, acExtendBoth)
        jiaodian2 = dimianxian.IntersectWith(shuline2, acExtendBoth)

        'shuline1.Delete  '删除竖线
        'shuline2.Delete
        '下面求分段坐标,调用zuobiaofenduan 坐标分段程序
        '参数是(jiaodian1 As Variant, jiaodian2 As Variant, dmxpline As AcadLWPolyline, fenduan() As Double)
        zuobiaofenduan jiaodian1, jiaodian2, dimianxian, fenduanzuobiao()
        'MsgBox UBound(fenduanzuobiao)

        '1画地面线
        huadimianxian qidian, dimianxian, fenduanzuobiao '已画好 dmxzdm

        ' qidiangaocheng  为新的地面线起始点高程
        'xinjizhungaocheng = yuanjizhungaocheng + (basepoint(1) - point(1)) * oldyscale / 1000
        qidiangaocheng = yuanjizhungaocheng + (fenduanzuobiao(1) - gcbasepoint(1)) * oldyscale / 1000
        'MsgBox qidiangaocheng

        dmxzdm.GetBoundingBox ccbox3, ccbox4
        '获取地面线的最大最小高程
        maxgc = qidiangaocheng + (ccbox4(1) - dmxzdm.Coordinates(1)) * yscale / 1000
        mingc = qidiangaocheng + (ccbox3(1) - dmxzdm.Coordinates(1)) * yscale / 1000
        'MsgBox maxgc
        'MsgBox mingc
        '2及其他有关的多段线
        '(point As Variant, zdmxian As AcadLWPolyline, zdmdingdian() As Double, yuandmx() As Double)
        'zdmxian 为原来的其他线
        'zdmdingdian() 为其他地面线的分段坐标 fenduanzuobiao1（）
        'yuandmx() 为原地面线的分段坐标，即fenduanzuobiao()

        '定义其他地面线数组
        ReDim xinqitaxian(0 To qitaxiancount) As AcadEntity
        If qitaxiancount >= 0 Then
            Dim ii As Double
            Dim zuida As Double
            Dim zuixiao As Double
            zuida = 0
            zuixiao = 0
            'MsgBox qitaxiancount
            For ii = 0 To qitaxiancount
                jiaodian1 = qitaxian(ii).IntersectWith(shuline1, acExtendBoth)
                jiaodian2 = qitaxian(ii).IntersectWith(shuline2, acExtendBoth)
                zuobiaofenduan jiaodian1, jiaodian2, qitaxian(ii), fenduanzuobiao1()
                huaqitaxian qidian, qitaxian(ii), fenduanzuobiao1, fenduanzuobiao   '已画好 qitadmxzdm
                'MsgBox UBound(fenduanzuobiao1)
                Set xinqitaxian(ii) = qitadmxzdm
                qitadmxzdm.GetBoundingBox ccbox1, ccbox2
                ccmaxgc = ccbox2(1) - ccbox4(1)
                ccmingc = ccbox3(1) - ccbox1(1)
                If ccmaxgc >= 0 Then
                    ccmaxgc = Int(ccmaxgc * yscale / 1000) + 1
                End If
                If ccmingc >= 0 Then
                    ccmingc = Int(ccmingc * yscale / 1000) + 1
                End If
                If ccmaxgc > zuida Then zuida = ccmaxgc
                If ccmingc > zuixiao Then zuixiao = ccmingc
            Next
            ccmaxgc = zuida
            ccmingc = zuixiao
        End If

        '求最大高程和最小高程,用于移动其他地面线，也为标尺干提供最大和最小高程
        maxgc = Int(maxgc)
        mingc = Int(mingc) - dy * ndy
        maxgc = maxgc + ccmaxgc
        mingc = mingc - ccmingc

        '2画标尺杆
        huabiaochigan qidian  ', mingc, maxgc, yscale, zigao, dy

        'qidiangaocheng 起点高程有了，直接移动，
        '移动地面线和其他地面线，用于后边的求高程值
        'MsgBox qidiangaocheng
        'MsgBox mingc
        yidongpt1(0) = qidian(0)
        yidongpt1(1) = qidian(1)
        yidongpt2(0) = qidian(0)
        yidongpt2(1) = qidian(1) + (qidiangaocheng - mingc) * 1000 / yscale
        dmxzdm.Move yidongpt1, yidongpt2

        For ii = 0 To qitaxiancount
            xinqitaxian(ii).Move yidongpt1, yidongpt2
        Next



        '3画数据栏

        shujulan qidian, dmxzdm, i * fenfuchangdu, (i + 1) * fenfuchangdu ', zigao, xscale, mingc


        '求下一个分幅插入点
        qidian(0) = qidian(0) + fenfuchangdu * 1000# / xscale + 100
        shuline1.Delete  '删除竖线
        shuline2.Delete
    Next '整数段分幅结束

    '画最后一个分幅断面，

        Set shuline2 = ThisDrawing.ModelSpace.AddLine(ppp1, ppp2)
        Dim moduandian(0 To 2) As Double
        jiaodian2 = dimianxian.IntersectWith(shuline2, acExtendBoth)
        moduandian(0) = dimianxian.Coordinates(UBound(dimianxian.Coordinates) - 1)
        moduandian(1) = dimianxian.Coordinates(UBound(dimianxian.Coordinates))
        zuobiaofenduan jiaodian2, moduandian, dimianxian, fenduanzuobiao()
        '1画地面线
        huadimianxian qidian, dimianxian, fenduanzuobiao '已画好 dmxzdm

        ' qidiangaocheng  为新的地面线起始点高程
        'xinjizhungaocheng = yuanjizhungaocheng + (basepoint(1) - point(1)) * oldyscale / 1000
        qidiangaocheng = yuanjizhungaocheng + (fenduanzuobiao(1) - gcbasepoint(1)) * oldyscale / 1000
        'MsgBox qidiangaocheng

        dmxzdm.GetBoundingBox ccbox3, ccbox4
        '获取地面线的最大最小高程
        maxgc = qidiangaocheng + (ccbox4(1) - dmxzdm.Coordinates(1)) * yscale / 1000
        mingc = qidiangaocheng + (ccbox3(1) - dmxzdm.Coordinates(1)) * yscale / 1000

        '2及其他有关的多段线
        '(point As Variant, zdmxian As AcadLWPolyline, zdmdingdian() As Double, yuandmx() As Double)
        'zdmxian 为原来的其他线
        'zdmdingdian() 为其他地面线的分段坐标 fenduanzuobiao1（）
        'yuandmx() 为原地面线的分段坐标，即fenduanzuobiao()

        '定义其他地面线数组
        'ReDim xinqitaxian(0 To qitaxiancount - 1) As AcadEntity
        If qitaxiancount >= 0 Then
            'Dim ii As Double
            zuida = 0
            zuixiao = 0
            For ii = 0 To qitaxiancount
                jiaodian2 = qitaxian(ii).IntersectWith(shuline2, acExtendBoth)
                moduandian(0) = qitaxian(ii).Coordinates(UBound(qitaxian(ii).Coordinates) - 1)
                moduandian(1) = qitaxian(ii).Coordinates(UBound(qitaxian(ii).Coordinates))

                zuobiaofenduan jiaodian2, moduandian, qitaxian(ii), fenduanzuobiao1()
                huaqitaxian qidian, qitaxian(ii), fenduanzuobiao1, fenduanzuobiao   '已画好 qitadmxzdm
                'MsgBox UBound(fenduanzuobiao1)
                Set xinqitaxian(ii) = qitadmxzdm
                'Dim zuida As Double
                'Dim zuixiao As Double
                qitadmxzdm.GetBoundingBox ccbox1, ccbox2
                ccmaxgc = ccbox2(1) - ccbox4(1)
                ccmingc = ccbox3(1) - ccbox1(1)
                If ccmaxgc >= 0 Then
                    ccmaxgc = Int(ccmaxgc * yscale / 1000) + 1
                End If
                If ccmingc >= 0 Then
                    ccmingc = Int(ccmingc * yscale / 1000) + 1
                End If
                If ccmaxgc > zuida Then zuida = ccmaxgc
                If ccmingc > zuixiao Then zuixiao = ccmingc
            Next
            ccmaxgc = zuida
            ccmingc = zuixiao
        End If

        '求最大高程和最小高程,用于移动其他地面线，也为标尺干提供最大和最小高程
        maxgc = Int(maxgc)
        mingc = Int(mingc) - dy * ndy
        maxgc = maxgc + ccmaxgc
        mingc = mingc - ccmingc

        '2画标尺杆
        huabiaochigan qidian  ', mingc, maxgc, yscale, zigao, dy

        '移动地面线和其他地面线，用于后边的求高程值
        yidongpt1(0) = qidian(0)
        yidongpt1(1) = qidian(1)
        yidongpt2(0) = qidian(0)
        yidongpt2(1) = qidian(1) + (qidiangaocheng - mingc) * 1000 / yscale
        dmxzdm.Move yidongpt1, yidongpt2
        For ii = 0 To qitaxiancount
            xinqitaxian(ii).Move yidongpt1, yidongpt2
        Next

        '3画数据栏 ,

        shujulan qidian, dmxzdm, i * fenfuchangdu, changdu  ', zigao, xscale, mingc

        shuline2.Delete '删除竖线

    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, zdmdingdian() As Double)  'zdmxian 为原地面线
    'zdmdingdian() 为分段坐标 fenduanzuobiao（）
'    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
    '画新的地面线 dmxzdm 为新的地面线，前面假设的
    Set dmxzdm = ThisDrawing.ModelSpace.AddLightWeightPolyline(bakjuligaocheng)
    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
End Sub

'1-2画其他纵断面线
Private Sub huaqitaxian(point As Variant, zdmxian As AcadLWPolyline, zdmdingdian() As Double, yuandmx() As Double)
    'zdmdingdian() 为其他地面线的分段坐标 fenduanzuobiao1（）
    'yuandmx() 为原地面线的分段坐标，即fenduanzuobiao()
    '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(0 To 2) As Double
'    Dim qidian2(0 To 2) As Double
'    qidian1(0) = bakjuligaocheng(0): qidian1(1) = bakjuligaocheng(1) 'zdmdingdian 是原来的其他地面线的顶点，
'    qidian2(0) = yuandmx(0): qidian2(1) = yuandmx(1) 'yuandmx 是原来的地面线的顶点，
'
    Dim movept(0 To 2) As Double
    Dim movept1(0 To 2) As Double
'    'movept(0) = point(0)
'    'movept(1) = point(1) + (qidiangaocheng - mingc) * 1000 / yscale
'    'qitadmxzdm.Move point, movept '移动到新的地面线的起始点上
'    qitadmxzdm.Move qidian1, qidian2   '移动到新的地面线的起始点上
'
    'movept1(0) = movept(0) + (qidian1(0) - qidian2(0)) * oldxscale / xscale
    'movept1(1) = movept(1) + (qidian1(1) - qidian2(1)) * oldyscale / yscale
    'qitadmxzdm.Move movept, movept1 zdmdingdian() As Double, yuandmx

    movept(0) = qitadmxzdm.Coordinates(0)
    movept(1) = qitadmxzdm.Coordinates(1)
    movept1(0) = movept(0)
    movept1(1) = movept(1) + (zdmdingdian(1) - yuandmx(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)

    '把最小高程赋给 mingc,用于后面的移动
    'mingc = min
End Sub

'3 画数据栏
Private Sub shujulan(point As Variant, dmxpline As AcadLWPolyline, qishizhuanghao As Double, zhongzhizhuanghao 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)
    Dim length As Double
    length = zhongzhizhuanghao - qishizhuanghao

    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 = qishizhuanghao
    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 = qishizhuanghao + dx                                                                              '|
    Do While zhuanghao < zhongzhizhuanghao    '循环添加桩号和高程                                               '|桩
        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   '最后一个桩号
    If zhongzhizhuanghao <> Int(zhongzhizhuanghao) Then                                                                                            '|
        Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhongzhizhuanghao, "0+000.00"), textpoint, zigao)     '|程
    Else
        Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhongzhizhuanghao, "0+000"), textpoint, zigao)
    End If
        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

    '设置纵断面分幅长度
'    ComboBox9.AddItem 5
'    ComboBox9.AddItem 10
'    ComboBox9.AddItem 20
'    ComboBox9.AddItem 25
'    For i = 0 To 3
'        ComboBox9.AddItem 10 * ComboBox9.List(i)
'    Next
    For i = 1 To 500
        ComboBox9.AddItem i * 10
    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


'用于求每一段的坐标，用于画每一个分幅中的地面线
Private Sub zuobiaofenduan(jiaodian1 As Variant, jiaodian2 As Variant, dmxpline As AcadLWPolyline, fenduan() As Double)
    'dmxpline 为地面线，也可以是其他的线
    Dim p1(0 To 2) As Double, p2(0 To 2) As Double
    Dim count As Integer, i As Integer, j As Integer  'i是多段线的分幅线段起始索引编号,j是多段线的分幅线段末端索引编号
    Dim d1 As Double, d2 As Double, d3 As Double
    count = UBound(dmxpline.Coordinates) \ 2
    For i = 0 To count - 1
        d1 = distance(dmxpline.Coordinate(i), jiaodian1)
        d2 = distance(jiaodian1, dmxpline.Coordinate(i + 1))
        d3 = distance(dmxpline.Coordinate(i), dmxpline.Coordinate(i + 1))
        p1(0) = dmxpline.Coordinate(i)(0)
        p1(1) = dmxpline.Coordinate(i)(1)
        p2(0) = dmxpline.Coordinate(i + 1)(0)
        p2(1) = dmxpline.Coordinate(i + 1)(1)
        'MsgBox angle1 & Chr(13) & angle2
        If Abs((d1 + d2 - d3) / d3) <= 0.0001 Then '''距离太小
           Exit For
        End If
    Next
    'MsgBox i
    For j = 0 To count - 1
        d1 = distance(dmxpline.Coordinate(j), jiaodian2)
        d2 = distance(jiaodian2, dmxpline.Coordinate(j + 1))
        d3 = distance(dmxpline.Coordinate(j), dmxpline.Coordinate(j + 1))
        p1(0) = dmxpline.Coordinate(j)(0)
        p1(1) = dmxpline.Coordinate(j)(1)
        p2(0) = dmxpline.Coordinate(j + 1)(0)
        p2(1) = dmxpline.Coordinate(j + 1)(1)
        'MsgBox angle1 & Chr(13) & angle2
        If Abs((d1 + d2 - d3) / d3) < 0.01 Then
           Exit For
        End If
    Next
    '已经确定分幅段的起始编号了
    '下面将从地面线中提取分段的坐标，并存入 参数fenduan()数组中
    'fenduan()=jiaodian1(0),jiaodian1(1),Coordinate(i+1)-->Coordinate(j)
    Dim fenduanzuobiaogeshu As Double
    fenduanzuobiaogeshu = (j - i) * 2 + 3
    ReDim fenduan(0 To fenduanzuobiaogeshu)
    fenduan(0) = jiaodian1(0): fenduan(1) = jiaodian1(1)
    fenduan(fenduanzuobiaogeshu - 1) = jiaodian2(0)
    fenduan(fenduanzuobiaogeshu) = jiaodian2(1)
    Dim k As Integer
    Dim h As Integer
    h = 1
    For k = i + 1 To j
        fenduan(h * 2) = dmxpline.Coordinate(k)(0)
        fenduan(h * 2 + 1) = dmxpline.Coordinate(k)(1)
        h = h + 1
    Next
End Sub

'求两点之间的距离
Function distance(sp As Variant, ep As Variant) As Double
    Dim dx As Double, dy As Double, dz As Double
    dx = sp(0) - ep(0)
    dy = sp(1) - ep(1)
    'dz = sp(2) - ep(2)
    distance = Sqr(dx ^ 2 + dy ^ 2)
End Function

lxl217114

太赞了，分享这么多的工具，都可以整成一个工具集了。

cq_qg

很佩服，十分感谢！

czb203

太赞了，分享这么多的工具，都可以整成一个工具集了。