沙漠骆驼工具箱源码-19地形图切剖面

woxing1987

工具条：地形图切剖面（根据等高线标高）
1 界面


2代码如下



Private Type dingdianzuobbiao   '自定义多段线顶点坐标
    xy As Variant
    distance As Double
End Type


Private Type jiaodianzuobiao   '定义交点xy坐标，含有高程，距离
    xy As Variant
    z As Double
    distance As Double
End Type


Dim pqxdingdian() As dingdianzuobbiao  '定义剖切线顶点坐标
Dim jiaodian() As jiaodianzuobiao  '定义交点坐标，有高程信息
Dim jiaodianzongshu As Double     '定义交点坐标个数
Dim juligaocheng() As Double
Dim zigao As Single   '字体高度
Dim xscale As Double    '定义x方向比例
Dim yscale As Double   '设置垂直比例
Dim maxgc As Double     '设置最大高程
Dim mingc As Double     '设置最小高程
Dim pqxlength As Double        '定义剖切线长度
'Dim pqxstartpoint(0 To 2)  As Double   '定义剖切线起始点坐标
'Dim pqxendpoint(0 To 2)   As Double    '定义剖切线终点坐标
'Dim pqxstartpoint As Variant
'Dim pqxendpoint As Variant
Dim pqxqidian As Variant   '定义剖切线的起点位置
Dim dy As Integer      '设置高程间隔距离，单位为m
Dim dx As Double       '设置水平间隔距离，单位为m
Dim ndy As Integer    '设置标尺干最下面多出的距离为 n*dy
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
Dim currentlineweight As String
Dim currentosmode As Integer
Dim pqxpline As AcadLWPolyline  '定义剖切线
Dim dmxpline As AcadLWPolyline  '定义地面线
Dim dgxlayername As String '确定选择的等高线图层名称
Dim biaochiganlayer As AcadLayer '定义标尺杆图层
Dim shujulanlayer  As AcadLayer '定义数据栏图层
Dim dimianxianlayer  As AcadLayer '定义地面线图层
Dim biaotilayer As AcadLayer      '定义标题文字图层
Dim pptlive As AcadLWPolyline  '定义交点显示符号，两个多段线圆圈，并显示宽度
Dim pouqiefangxiang As Boolean  '定义剖切方向，为布尔型变量


Private Sub ComboBox1_Click()
    dgxlayername = ComboBox1.Text
End Sub


Private Sub CommandButton1_Click()  '1 确定等高线图层之后，选择剖切线
    Me.Hide
    On Error Resume Next
    quxiao '调用取消命令
    If dgxlayername = "" Then
        ThisDrawing.Utility.prompt "-----等高线图层获取错误，请重新获取等高线图层------" & vbCrLf
        Exit Sub
    End If
    '选择剖切线
    '删除显示的点
    pptlive.Delete
    If Error.Err Then Err.Clear
    Dim base As Variant
    ThisDrawing.Utility.GetEntity pqxpline, base, "请点选剖切线，必须为多段线:" & vbCrLf
    If Err.Number <> 0 Then
        ThisDrawing.Utility.prompt "-----剖切线选取失败------" & vbCrLf
        Me.show
        Err.Clear
        Exit Sub
    End If
    pqxpline.Elevation = 0 '将剖切线标高归零，以便后面使用
    ThisDrawing.Utility.prompt "-----剖切线选取成功------" & vbCrLf
    currentosmode = ThisDrawing.GetVariable("OSMODE")
    ThisDrawing.SetVariable "OSMODE", 1
    pqxpline.Highlight True
    pqxqidian = ThisDrawing.Utility.GetPoint(, "请选取剖切的起点位置：")
    pqxpline.Highlight False
    ThisDrawing.SetVariable "OSMODE", currentosmode
    getjiaodian pqxpline, pqxqidian
    '如果以上选择都正确的话，将显示窗体
    Me.height = 274   '改变窗体大小,274,121
    Me.width = 225
    ListBox1.Clear
    Label15.Visible = True
    Label16.Visible = False
    Me.show
End Sub
'2 然后插入剖面图，包括标尺杆，数据栏，地面线
Private Sub CommandButton2_Click()
    On Error Resume Next   '删除交点显示符号，两个多段线圆圈
    quxiao '调用取消命令
    pptlive.Delete
    If Error.Err Then Err.Clear
    Me.Hide
    zigao = ComboBox4.Text
    yscale = ComboBox2.Text
    xscale = ComboBox3.Text
    dy = Left(ComboBox5.Text, 2)
    dx = ComboBox6.Text
    ndy = ComboBox7.Text
    On Error Resume Next
    currentlayername = ThisDrawing.ActiveLayer.name
    currentcolor = ThisDrawing.GetVariable("cecolor")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    currentlineweight = ThisDrawing.Preferences.Lineweight
    Set currentlinetype = ThisDrawing.ActiveLinetype
    ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item(1) '设置线形为bylayer
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ThisDrawing.Preferences.Lineweight = acLnWtByLayer   '设置默认线宽
    Dim base As Variant
    base = ThisDrawing.Utility.GetPoint(, "请选取插入点：")
    huabiaochigan base, mingc, maxgc, yscale, zigao, dy   '插入左标尺杆
    If CheckBox2.value Then                               '插入右标尺杆
        Dim base2(0 To 2) As Double
        base2(0) = base(0) + 1.5 + pqxlength * 1000 / xscale    '+10
        base2(1) = base(1)
        youhuabiaochigan base2, mingc, maxgc, yscale, zigao, dy
    End If
    'base(0) = base(0) + 10 '向右平移10个单位
    huadimianxian base, xscale, yscale, mingc, juligaocheng  '先画地面线，数据栏里的数据根据地面线生成
    'base(0) = base(0) - 10
    shujulan base, pqxlength, zigao, xscale, mingc         ' 插入数据栏外框,  + 10 * xscale / 1000
   
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername) '恢复图层
    ThisDrawing.SetVariable "cecolor", currentcolor '恢复绘图颜色
    ThisDrawing.SetVariable "textstyle", currenttextstyle
    ThisDrawing.ActiveLinetype = currentlinetype '恢复线型
    ThisDrawing.Preferences.Lineweight = currentlineweight
    Me.show
End Sub


Private Sub CommandButton3_Click()
    Me.Hide
End Sub
'包含有如下几个方面:
'用剖切线栏选对象以创建选择集,选择等高线层
'返回剖切线与选择集的交点坐标,还包含距离和高程
'返回最大高程，最小高程
Private Sub getjiaodian(plineobj As AcadLWPolyline, qidian As Variant)     '参数为剖切线和剖切方向的起始点
    On Error Resume Next
    Dim i As Integer
    ReDim pqxdingdian(UBound(plineobj.Coordinates) \ 2)    '重新定义剖切线顶点坐标,并存储多段线定点坐标
    For i = 0 To UBound(plineobj.Coordinates) \ 2
        pqxdingdian(i).xy = plineobj.Coordinate(i)
        pqxdingdian(i).distance = plinedistancep1(pqxdingdian(i).xy, plineobj)
        'MsgBox pqxdingdian(i).distance
    Next
    pqxlength = plineobj.length  '剖切线长度
    plineobj.Elevation = 0       '将剖切线标高归零
    Dim sset As AcadSelectionSet   '创建等高线选择集
    Dim count As Integer
    count = (UBound(plineobj.Coordinates) \ 2 + 1) * 3 - 1
    ReDim plinelist(count) As Double  '剖切线坐标列表，为三元数组,x,y,z 用于栏选等高线
    For i = 0 To UBound(plineobj.Coordinates) \ 2
        plinelist(i * 3) = plineobj.Coordinates(i * 2) '给x坐标赋值
        plinelist(i * 3 + 1) = plineobj.Coordinates(i * 2 + 1) '给y坐标赋值
        plinelist(i * 3 + 2) = 0  '给z坐标赋0值
    Next
    Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(4) As Variant '定义选择过滤器的值
        filtertype(0) = -4
        filterdata(0) = "<or"
        filtertype(1) = 0
        filterdata(1) = "lwpolyline"
        filtertype(2) = 0
        filterdata(2) = "polyline"
        filtertype(3) = -4
        filterdata(3) = "or>"
        filtertype(4) = 8
        filterdata(4) = dgxlayername
    '再加一个图层过滤器 屏幕放大了再选，要不然选不完
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    plineobj.GetBoundingBox boundary1, boundary2
    ThisDrawing.Application.ZoomWindow boundary1, boundary2
   
    Set sset = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset = ThisDrawing.SelectionSets.Item("ss1")
        sset.Clear
    End If
    sset.SelectByPolygon acSelectionSetFence, plinelist, filtertype, filterdata '栏选对象
    ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
    If sset.count = 0 Then
        dgxlayername = "" '如果没切到等高线，将dgxlayername 设为空值
        sset.Clear
        sset.Delete     '删除选择集
        Exit Sub        '并且退出
    End If
   
'测试选择集中对象的顺序,用不同的颜色显示
'    For i = 0 To sset.count - 1
'        Dim ceshipt(0 To 2) As Double
'        Dim aa  As AcadLWPolyline
'        Set aa = sset.Item(i)
'        ceshipt(0) = aa.Coordinates(0)
'        ceshipt(1) = aa.Coordinates(1)
'        ThisDrawing.ModelSpace.AddText i, ceshipt, 8
'    Next
   
    Dim pqx As AcadLWPolyline        '下面排除剖切线，剖切线也在选择集里
    Dim removeobjects(0) As AcadObject  '移出对象数组，
    For i = 0 To sset.count - 1
        Set pqx = sset.Item(i)
        If pqx.Coordinates(0) = plineobj.Coordinates(0) And _
            pqx.Coordinates(1) = plineobj.Coordinates(1) And _
            pqx.Coordinates(2) = plineobj.Coordinates(2) And _
            pqx.Coordinates(3) = plineobj.Coordinates(3) Then
            Set removeobjects(0) = pqx
            sset.RemoveItems removeobjects      '把剖切线从选择集中移出
            'pqx.color = acRed
            Exit For
        End If
    Next
    Dim jiaodiangeshu As Double      '定义jiaodiangeshu 为过程变量，
    Dim maxjiaodiangeshu As Double
    maxjiaodiangeshu = 500          '500 假设剖切线与同一条等高线最多有500个交点，一般不会这么多
    ReDim maxjiaodian(maxjiaodiangeshu) As jiaodianzuobiao  '定义局部变量数组
    mingc = sset.Item(0).Elevation '初始最小高程
    maxgc = sset.Item(0).Elevation '初始最大高程
    'MsgBox mingc & "," & maxgc
    maxjiaodian(0).z = sset.Item(0).Elevation
    maxjiaodian(0).xy = pqxdingdian(0).xy
    maxjiaodian(0).distance = 0
    i = 0
    Dim j As Double
    Dim ii As Double
    Dim kuandui As Double
    ReDim kuandu(sset.count - 1) As Double '定义多段线宽度
   
'    For kuandui = 0 To sset.count - 1     '设置等高线宽度为0，以便于求交点
'        kuandu(kuandui) = sset.Item(kuandui).ConstantWidth
'        sset.Item(kuandui).ConstantWidth = 0
'    Next
    Dim pp As Variant    '用于存放大于一个交点的情况
    Dim countpp As Double  '用于存放pp的上限值
    Dim minlinghangxianshi As Long  '用于命令行显示进度个数
    minlinghangxianshi = 1
    Dim kaishishijian As Variant
    Dim jieshushijian As Variant
    '计时开始
    kaishishijian = ThisDrawing.GetVariable("cdate")
    'MsgBox ThisDrawing.GetVariable("tdusrtimer")
    For ii = 1 To sset.count
        i = i + 1
        maxjiaodian(i).z = sset.Item(ii - 1).Elevation  '存储等高线高程
        'MsgBox maxjiaodian(i).z
        If maxjiaodian(i).z > maxgc Then maxgc = maxjiaodian(i).z '获取最大高程
        If maxjiaodian(i).z < mingc Then mingc = maxjiaodian(i).z '获取最小高程
        sset.Item(ii - 1).Elevation = 0              '将等高线标高归零
        'kuandu = sset.Item(ii - 1).ConstantWidth         '存储等高线宽度
        'If kuandu <> 0 Then sset.Item(ii - 1).ConstantWidth = 0     '将等高线宽度设为0
        'sset.Item(ii - 1).ConstantWidth = 0
        pp = sset.Item(ii - 1).IntersectWith(plineobj, acExtendNone) '求交点
        sset.Item(ii - 1).Elevation = maxjiaodian(i).z  '恢复等高线标高数值
        'If kuandu <> 0 Then sset.Item(ii - 1).ConstantWidth = kuandu  '恢复等高线宽度
        'sset.Item(ii - 1).ConstantWidth = kuandu
   
        countpp = (UBound(pp) + 1) \ 3     '同一条等高线的交点个数
        If countpp > 1 Then           '同一条等高线的交点个数大于1时
            Dim cc(0 To 2) As Double      '用来传递坐标值
            For j = 0 To countpp - 1
                cc(0) = pp(3 * j)
                cc(1) = pp(3 * j + 1)
                cc(2) = 0
                maxjiaodian(i + j).xy = cc
                maxjiaodian(i + j).z = maxjiaodian(i).z
                'ThisDrawing.ModelSpace.AddText maxjiaodian(i + j).z, maxjiaodian(i + j).xy, 20
               
                ThisDrawing.Utility.prompt "正在处理第 " & minlinghangxianshi & " 个交点" & vbCrLf
                minlinghangxianshi = minlinghangxianshi + 1
            Next
            i = i + j - 1
        Else                           '同一条等高线的交点个数等于1时
            maxjiaodian(i).xy = pp
        End If
        
        '命令行显示正在处理的交点
        ThisDrawing.Utility.prompt "正在处理第 " & minlinghangxianshi & " 个交点" & vbCrLf
        minlinghangxianshi = minlinghangxianshi + 1
    Next
'    For kuandui = 0 To sset.count - 1
'        sset.Item(kuandui).ConstantWidth = kuandu(kuandui)
'    Next
    'MsgBox ThisDrawing.GetVariable("tdusrtimer")
    '计时结束
    jieshushijian = ThisDrawing.GetVariable("cdate")
    'MsgBox str((jieshushijian - kaishishijian) * 1000000)
    ThisDrawing.Utility.prompt "一共处理了 " & minlinghangxianshi - 1 & " 个交点。 @@@共耗时 " _
               & Format((jieshushijian - kaishishijian) * 1000000, "0.000000") & " 秒@@@" & vbCrLf
   
    jiaodiangeshu = i + 1           '确定实际存在的交点个数
    ReDim jiaodian(jiaodiangeshu)   '重新定义交点坐标数组
    For i = 0 To jiaodiangeshu - 1
        jiaodian(i).xy = maxjiaodian(i).xy
        jiaodian(i).z = maxjiaodian(i).z
        jiaodian(i).distance = plinedistancep1(jiaodian(i).xy, plineobj) '调用函数，计算交点距多段线起点的距离
        'ThisDrawing.ModelSpace.AddText i, jiaodian(i).xy, 3
        'ThisDrawing.ModelSpace.AddText jiaodian(i).z, jiaodian(i).xy, 3
    Next
'    With jiaodian(jiaodiangeshu)                        '加入剖切线末点
'        '.z = sset.Item(sset.count - 1).Elevation        '.z = jiaodian(jiaodiangeshu - 1).z
'        .xy = plineobj.Coordinate(UBound(plineobj.Coordinates) \ 2)  '二元数组
'        .distance = plinedistancep1(.xy, plineobj)
'    End With
   
    '到此完成了剖切线与等高线所有交点的坐标，并添加了剖切线的两个端点坐标
    '根据各交点坐标到起始点的距离distance进行排序
    Dim ttt As jiaodianzuobiao
    For i = 0 To jiaodiangeshu - 2
        For j = i + 1 To jiaodiangeshu - 1
            If jiaodian(i).distance > jiaodian(j).distance Then
                ttt = jiaodian(i)
                jiaodian(i) = jiaodian(j)
                jiaodian(j) = ttt
            End If
        Next
    Next
    jiaodian(jiaodiangeshu).xy = plineobj.Coordinate(UBound(plineobj.Coordinates) \ 2)   '二元数组
    jiaodian(jiaodiangeshu).distance = plineobj.length
    jiaodian(jiaodiangeshu).z = jiaodian(jiaodiangeshu - 1).z
    '下面确定剖切方向
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    ReDim juligaocheng(jiaodiangeshu * 2 + 1) As Double  '用于存放画剖面线的二元数组，距离，高程
    If Abs(qidian(0) - pqxdingdian(0).xy(0)) / pqxlength < 0.0001 And _
       Abs(qidian(1) - pqxdingdian(0).xy(1)) / pqxlength < 0.0001 Then  'qiandian 是参数变量
        pt1(0) = pqxdingdian(0).xy(0)
        pt1(1) = pqxdingdian(0).xy(1)
        pt2(0) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(0)
        pt2(1) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(1)
        For i = 0 To jiaodiangeshu                                '方向和多段线方向相同
            juligaocheng(2 * i) = jiaodian(i).distance
            juligaocheng(2 * i + 1) = jiaodian(i).z
            'ThisDrawing.ModelSpace.AddText juligaocheng(2 * i), jiaodian(i).xy, 0.5
        Next
        pouqiefangxiang = True
    Else    '剖切线方向和多段线方向相反 UBound(plineobj.Coordinates) \ 2
'        pt1(0) = jiaodian(jiaodiangeshu).xy(0): pt1(1) = jiaodian(jiaodiangeshu).xy(1)
'        pt2(0) = jiaodian(0).xy(0): pt2(1) = jiaodian(0).xy(1)
        pouqiefangxiang = False
        pt1(0) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(0)
        pt1(1) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(1)
        pt2(0) = pqxdingdian(0).xy(0)
        pt2(1) = pqxdingdian(0).xy(1)
        Dim ppt As Integer
        ppt = UBound(plineobj.Coordinates) \ 2
        Dim addpline As AcadLWPolyline          '新增加一个多段线，并且方向相反
        ReDim addplinelist(UBound(plineobj.Coordinates)) As Double
        For i = 0 To ppt
            pqxdingdian(i).xy = plineobj.Coordinate(ppt - i)
            addplinelist(2 * i) = pqxdingdian(i).xy(0)
            addplinelist(2 * i + 1) = pqxdingdian(i).xy(1)
        Next
        Set addpline = ThisDrawing.ModelSpace.AddLightWeightPolyline(addplinelist)
        For i = 0 To ppt
            pqxdingdian(i).distance = plinedistancep1(pqxdingdian(i).xy, addpline)
            'MsgBox pqxdingdian(i).distance
        Next
        For i = 0 To jiaodiangeshu                          '方向和多段线方向相反
            juligaocheng(2 * i) = plinedistancep1(jiaodian(jiaodiangeshu - i).xy, addpline)
            juligaocheng(2 * i + 1) = jiaodian(jiaodiangeshu - i).z
            'ThisDrawing.ModelSpace.AddText juligaocheng(2 * i), jiaodian(jiaodiangeshu - i).xy, 0.5
        Next
        addpline.Delete
    End If
    ThisDrawing.ModelSpace.AddText "1", pt1, 5   '添加剖切线起点方向，方向为1->2
    ThisDrawing.ModelSpace.AddText "2", pt2, 5
    TextBox1.Text = maxgc
    TextBox2.Text = mingc
    jiaodianzongshu = jiaodiangeshu - 1 '存储剖切线和等高线的交点个数，不包括两个端点
    sset.Delete
End Sub


'1画左标尺杆
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
    Dim max As Double
    Dim min As Double
    'If maxgc = Int(maxgc) Then max = Int(maxgc) Else max = Int(maxgc) + 1
    max = Int(maxgc) + dy
    min = Int(mingc) - dy * ndy
    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
End Sub
'1画右标尺杆
Private Sub youhuabiaochigan(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
    Dim max As Double
    Dim min As Double
    'If maxgc = Int(maxgc) Then max = Int(maxgc) + dy Else max = Int(maxgc) + 1
    max = Int(maxgc) + dy
    min = Int(mingc) - dy * ndy
    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) + 1.25: textpoint(1) = p1(1) '最下边的高程
    Set textobj = ThisDrawing.ModelSpace.AddText(min, textpoint, zigao)
    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 = acAlignmentMiddleLeft
            .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 = acAlignmentMiddleLeft
            .TextAlignmentPoint = textpoint
        End With
    Next
    textpoint(0) = p1(0) + 1.5: textpoint(1) = p1(3)   '最上边的高程文字：高程(m)
    Set textobj = ThisDrawing.ModelSpace.AddText("高程(m)", textpoint, zigao)
    With textobj
        .Alignment = acAlignmentTopLeft
        .TextAlignmentPoint = textpoint
    End With
End Sub


'2画地面线
Private Sub huadimianxian(point As Variant, xscale As Double, yscale As Double, mingc As Double, juligaocheng() As Double)
    Set dimianxianlayer = ThisDrawing.Layers.Add("地面线")
    ThisDrawing.ActiveLayer = dimianxianlayer
    Dim min As Double
    min = Int(mingc) - dy * ndy
    Dim count As Integer
    'newuserucs point   '新建坐标系，好像没用,那就不用了
    count = UBound(juligaocheng)
    ReDim bakjuligaocheng(count) As Double  '新建一个数组，原数组不动，因为数组是按地址(byref)传递的,
    Dim movevalue As Double
    movevalue = juligaocheng(1)
    'x方向起点已在原点，只在y方向平移一定的距离，使其起点也在原点上，
    '然后，x ,y方向再放大相应的倍数， '以实现x ,y方向不同比例的缩放
    '最后在移到原起始坐标上
    For i = 0 To count \ 2
        bakjuligaocheng(2 * i) = juligaocheng(2 * i) * 1000 / xscale
        bakjuligaocheng(2 * i + 1) = (juligaocheng(2 * i + 1) - movevalue) * 1000 / yscale
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + (movevalue - min) * 1000 / yscale
        bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) + point(0)
        bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + point(1)
    Next
    Set dmxpline = ThisDrawing.ModelSpace.AddLightWeightPolyline(bakjuligaocheng)
    dmxpline.ConstantWidth = 0.12
End Sub
'3画数据栏
Private Sub shujulan(point As Variant, length As Double, zigao As Single, xscale As Double, mingc As Double)
    Set shujulanlayer = ThisDrawing.Layers.Add("数据栏")
    ThisDrawing.ActiveLayer = shujulanlayer
    shujulanlayer.color = acCyan
    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 * ndy
    Dim zhuanghao As Double     '桩号 数据
    Dim gaocheng As Double      '高程 数据
    Dim zhjltext As AcadText    '桩号，高程文字
    zhuanghao = juligaocheng(0)
    gaocheng = juligaocheng(1)                                          '----------------------------
    textpoint(0) = point(0): textpoint(1) = point(1) - 7   '第一个桩号0+000                          |
    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
                                                             '----------------------------------- --|
    '下面添加剖切线拐点桩号
    Dim max As Double
    Dim h As Double
    max = Int(maxgc) + dy
    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 CheckBox3.value Then
        If UBound(pqxdingdian) > 1 Then
            Dim countguaidian As Integer
            Dim i As Integer
            countguaidian = UBound(pqxdingdian) - 1 '拐点个数
            ReDim guaidian(countguaidian) As Double
            For i = 1 To countguaidian
                zhuanghao = pqxdingdian(i).distance
                textpoint(0) = point(0) + zhuanghao * 1000 / xscale: textpoint(1) = point(1) - 7
                Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000.00"), textpoint, zigao)
                    zhjltext.Alignment = acAlignmentBottomCenter
                    zhjltext.TextAlignmentPoint = textpoint
                    zhjltext.Rotation = 3.1415926 / 2
                    zhjltext.color = acRed
                pt(0) = textpoint(0): pt(1) = point(1)
                pt(2) = textpoint(0): pt(3) = point(1) - 28
                Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
                    plineobj.color = acRed
                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
                    zhjltext.color = acRed
                pt(3) = point(1) + h * 1000 / yscale
                Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
                    plineobj.color = acRed
                textpoint(1) = point(1) + 2
                Set zhjltext = ThisDrawing.ModelSpace.AddText("拐点" & i, textpoint, zigao)
                    zhjltext.Alignment = acAlignmentBottomLeft
                    zhjltext.TextAlignmentPoint = textpoint
                    zhjltext.Rotation = 3.1415926 / 2
                    zhjltext.color = acRed
            Next
        End If
    End If
     '下面添加标题名称 ，比例尺，和桩号距离
    Set biaotilayer = ThisDrawing.Layers.Add("标题文字")
    ThisDrawing.ActiveLayer = biaotilayer
    biaochiganlayer.color = acGreen
    Dim biaotitext As AcadText
    textpoint(0) = point(0) + length * 1000 / xscale / 2
    textpoint(1) = point(1) + (h + 2) * 1000 / yscale + 25
    Set biaotitext = ThisDrawing.ModelSpace.AddText("1-2 纵 断 面 图", textpoint, 7)
        biaotitext.Alignment = acAlignmentBottomCenter
        biaotitext.TextAlignmentPoint = textpoint
    textpoint(1) = textpoint(1) - 9
    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


'求两点之间的距离,参数是x1,y1,x2,y2
Private Function distance(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Double
    distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5
End Function
'求两点之间的距离,参数是(x1,y1),(x2,y2)
Private Function distancep1p2(ByVal p1 As Variant, ByVal p2 As Variant) As Double
    distancep1p2 = ((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2) ^ 0.5
End Function


'计算并返回多段线上的一点到起始点的距离
Private Function plinedistancep1(xy As Variant, plineobj As AcadLWPolyline) As Double
    Dim p1 As Variant
    Dim p2 As Variant
    Dim count As Integer, i As Integer 'i是多段线的线段索引编号
    Dim d1 As Double, d2 As Double, d3 As Double
    count = UBound(plineobj.Coordinates) \ 2
    plinedistancep1 = 0
    For i = 0 To count - 1
        p1 = plineobj.Coordinate(i)
        p2 = plineobj.Coordinate(i + 1)
        d1 = distancep1p2(p1, xy)
        d2 = distancep1p2(xy, p2)
        d3 = distancep1p2(p1, p2)
        plinedistancep1 = plinedistancep1 + d3
        If Abs((d1 + d2 - d3) / d3) < 0.0001 Then      '0.0001 越小越精确,但有时会出现莫名其妙的问题
            plinedistancep1 = plinedistancep1 - d2
            'MsgBox d1 & Chr(13) & d2 & Chr(13) & d1 + d2 & Chr(13) & d3
            Exit For
        End If
    Next
End Function


'创建新的用户坐标系 “userucs”
Sub newuserucs(point As Variant)
    'Dim ucsObj As AcadUCS
    Dim origin(0 To 2) As Double
    Dim xAxisPnt(0 To 2) As Double
    Dim yAxisPnt(0 To 2) As Double
    ' 定义 UCS 点
    origin(0) = point(0): origin(1) = point(1): origin(2) = 0
    xAxisPnt(0) = point(0) + 1: xAxisPnt(1) = point(1): xAxisPnt(2) = 0
    yAxisPnt(0) = point(0): yAxisPnt(1) = point(1) + 1: yAxisPnt(2) = 0
    '创建新的用户坐标系，并激活新建用户坐标系
    ' 添加 UCS 到 UserCoordinatesSystems 集合中
    ThisDrawing.ActiveUCS = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "userucs")
    'ThisDrawing.Application.Update
End Sub


'恢复上一个坐标系
Private Sub userucstowcs()
    ThisDrawing.SendCommand "_ucs" & vbCr & "p" & vbCr
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 CommandButton4_Click()
    MsgBox "时间：2012年2月06日    " & vbCr & _
           "名称：地形图切剖面 V1.3    " & vbCr & _
           "by  ：沙漠骆驼    " & vbCr & _
           "qq  ：549738552    " & vbCr & vbCr & _
           "当前时间：" & Date & vbCr & _
           "               " & Time, vbInformation, "地形图切剖面--by沙漠骆驼"
End Sub
Private Sub Label11_Click()
'选取等高线，以获取等高线所在的图层名称
    On Error Resume Next
    Me.Hide
    quxiao '调用取消命令
    ComboBox1.Enabled = False
    Label1.Enabled = True
    Dim plineobj As AcadEntity
    Dim base As Variant
   
    ThisDrawing.Utility.GetEntity plineobj, base, "请选取等高线，以获取等高线所在的图层名称:" & vbCrLf
    If Err.Number <> 0 Or (plineobj.ObjectName <> "AcDb2dPolyline" And plineobj.ObjectName <> "AcDbPolyline") Then
        ThisDrawing.Utility.prompt "-----等高线选取失败------" & vbCrLf
        Me.show
        Exit Sub
    End If
    ThisDrawing.Utility.prompt "-----获取等高线图层成功，请继续下一步操作，选取剖切线-----" & vbCrLf
    dgxlayername = plineobj.Layer
    Label1.Caption = dgxlayername
    Me.height = 121   '改变窗体大小,274,121
    Me.width = 225
    Me.show
End Sub


Private Sub Label13_Click()
    Me.height = 121
    Me.width = 225
    ComboBox1.Enabled = True
    Label1.Enabled = False
    ComboBox1.Clear
    For Each layerobj In ThisDrawing.Layers
        ComboBox1.AddItem Trim(layerobj.name)
    Next
    ComboBox1.Text = ComboBox1.List(0)
End Sub


Private Sub Label15_Click()
    ListBox1.Clear
    If pouqiefangxiang = True Then
        For i = 1 To jiaodianzongshu
            ListBox1.AddItem Format(i, "!@@@@@@") & jiaodian(i).z
        Next
    Else
        For i = jiaodianzongshu To 1 Step -1
            ListBox1.AddItem Format(jiaodianzongshu - i + 1, "!@@@@@@") & jiaodian(i).z
        Next
    End If
    TextBox4.Text = maxgc
    TextBox3.Text = mingc
    Label15.Visible = False
    Label16.Visible = True
    Me.width = 330
End Sub


Private Sub Label16_Click()
    On Error Resume Next
    pptlive.Delete
    If Error.Err Then Err.Clear
    Label15.Visible = True
    Label16.Visible = False
    Me.width = 225
End Sub


Private Sub ListBox1_Click()
    Dim i As Integer
    On Error Resume Next
    pptlive.Delete
    i = Left(ListBox1.Text, 5)
    If pouqiefangxiang = False Then i = jiaodianzongshu - i + 1
    Dim zhongxin(0 To 11) As Double '定义交点坐标
    zhongxin(0) = jiaodian(i).xy(0) - 2: zhongxin(1) = jiaodian(i).xy(1)
    zhongxin(2) = jiaodian(i).xy(0) + 2: zhongxin(3) = jiaodian(i).xy(1)
    zhongxin(4) = jiaodian(i).xy(0) - 2: zhongxin(5) = jiaodian(i).xy(1)
    zhongxin(6) = jiaodian(i).xy(0) - 0.6: zhongxin(7) = jiaodian(i).xy(1)
    zhongxin(8) = jiaodian(i).xy(0) + 0.6: zhongxin(9) = jiaodian(i).xy(1)
    zhongxin(10) = jiaodian(i).xy(0) - 0.6: zhongxin(11) = jiaodian(i).xy(1)
    If Error.Err Then Err.Clear
    Set pptlive = ThisDrawing.ModelSpace.AddLightWeightPolyline(zhongxin)
    With pptlive
        .SetWidth 0, 0.5, 0.5
        .SetWidth 1, 0.5, 0.5
        .SetWidth 2, 0, 0
        .SetWidth 3, 1.2, 1.2
        .SetWidth 4, 1.2, 1.2
        .SetBulge 0, 1
        .SetBulge 1, 1
        .SetBulge 3, 1
        .SetBulge 4, 1
        .color = acGreen
    End With
    Dim box1 As Variant
    Dim box2 As Variant
    pptlive.GetBoundingBox box1, box2
    box1(0) = box1(0): box1(1) = box1(1) - 40
    box2(0) = box2(0) + 100: box2(1) = box2(1) + 60
    ThisDrawing.Application.ZoomWindow box1, box2
End Sub


Private Sub UserForm_Initialize()
    ComboBox1.Clear '设置图层
    For Each layerobj In ThisDrawing.Layers
        ComboBox1.AddItem layerobj.name
    Next
    ComboBox1.Text = ThisDrawing.Layers.Item(0).name
    Dim i As Integer
    For i = 1 To 9  '设置字体高度
        ComboBox4.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    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
    ComboBox3.AddItem 1
    ComboBox3.AddItem 2
    ComboBox3.AddItem 5
    ComboBox3.AddItem 10   '设置水平比例
    ComboBox3.AddItem 20
    ComboBox3.AddItem 25
    ComboBox3.AddItem 50
    For i = 3 To 6
        ComboBox3.AddItem 10 * ComboBox3.List(i)
    Next
    For i = 3 To 6
        ComboBox3.AddItem 100 * ComboBox3.List(i)
    Next
    For i = 3 To 6
        ComboBox3.AddItem 1000 * ComboBox3.List(i)
    Next
    ComboBox5.AddItem "01m"   '设置高程间隔距离
    ComboBox5.AddItem "02m"
    ComboBox5.AddItem "05m"
    ComboBox5.AddItem "10m"
    ComboBox5.AddItem "20m"
    ComboBox5.AddItem "25m"
    ComboBox5.AddItem "40m"
    ComboBox5.AddItem "50m"
   
    '设置桩号间距
    ComboBox6.AddItem 5
    ComboBox6.AddItem 10
    ComboBox6.AddItem 20
    ComboBox6.AddItem 25
    For i = 0 To 3
        ComboBox6.AddItem 10 * ComboBox6.List(i)
    Next
    For i = 0 To 3
        ComboBox6.AddItem 100 * ComboBox6.List(i)
    Next
    '设置标尺干的超出长度，为 n * dy
    For i = 1 To 10
        ComboBox7.AddItem i
    Next
   
    newtextstyle2 '调用新建字体样式程序
    Me.height = 121
    Me.width = 225
    dgxlayername = ""
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    pptlive.Delete
    If Error.Err Then Err.Clear
End Sub

cq_qg

感谢无私分享！

czb203

感谢无私分享！

weihong515

感谢无私分享！

weihong515

你好，请问这个哦工具的命令是什么呢，本人刚开始学习中

chixun99

谢谢，学习一下。可贵的是都是vba的。

y854271613

感谢无私分享！

vladimirputin

非常不错的代码，谢谢楼主分享吖

jiangqian124

脑壳都看麻了，我的天呀