沙漠骆驼工具箱源码-22插入标尺杆（地质相关）

woxing1987

工具条：插入标尺杆
1界面


2源代码如下





'插入标尺杆
'2011年12月6日22:20:42
'by 沙漠骆驼
'for whlkx
Dim zigao As Single   '字体高度
Dim yscale As Double   '设置垂直比例
Dim maxgc As Double     '设置最大高程
Dim mingc As Double     '设置最小高程
Dim dy As Integer      '设置间隔距离，单位为m
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
Dim currentlineweight As String
Dim biaochiganlayer As AcadLayer


Private Sub CommandButton1_Click()
    Me.Hide
    On Error Resume Next
   
    quxiao '调用取消命令
    If TextBox1.Text * 1# <= TextBox2.Text * 1# Or Trim(TextBox1.Text) = "" Or Trim(TextBox2.Text) = "" Then
        MsgBox "请输入重新输入最大高程或最小高程", vbCritical, "警告--by沙漠骆驼"
        biaochigan.show
        Exit Sub
    End If
    zigao = ComboBox1.Text
    yscale = ComboBox2.Text
    maxgc = TextBox1.Text
    mingc = TextBox2.Text
    dy = Left(ComboBox3.Text, 2)
   
    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
    Set biaochiganlayer = ThisDrawing.Layers.Add("标尺杆")
    ThisDrawing.ActiveLayer = biaochiganlayer
    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
   
    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 huabiaochigan(point As Variant, mingc As Double, maxgc As Double, yscale As Double, zigao As Single, dy As Integer)
    '根据最大和最小高程的差值范围来自动确定间隔距离
   
    Dim max As Double
    Dim min As Double
    If maxgc = Int(maxgc) Then max = Int(maxgc) Else max = Int(maxgc) + 1
    min = Int(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 = acAlignmentBottomRight
        .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


Private Sub CommandButton2_Click()
    Me.Hide
    Me.show
End Sub


Private Sub CommandButton3_Click()
    Me.Hide
End Sub


Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Me.Hide
    Me.show vbModal
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Me.Hide
    Me.show vbModal
End Sub


Private Sub UserForm_Initialize()
    Dim i As Integer
    For i = 1 To 19  '设置字体高度
        ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    ComboBox2.AddItem 1 '设置垂直比例1-50000
    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 "01m" '设置高程间隔
    ComboBox3.AddItem "02m"
    ComboBox3.AddItem "05m"
    ComboBox3.AddItem "10m"
    ComboBox3.AddItem "20m"
    ComboBox3.AddItem "25m"
    ComboBox3.AddItem "40m"
    ComboBox3.AddItem "50m"
    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

lxl217114

大佬的分享精神值得学习+2

403181713

向大佬学习

paulpz

谢谢楼主，学习围观