沙漠骆驼工具箱源码-24插入年代符号（地质相关）

woxing1987

工具条：插入年代符号1界面

2代码如下



Dim mtextobj As AcadMText
Dim texthight As Double
Dim textcolor As String
Dim insertbase As Variant
Dim width As Double
Dim textstring As String
Dim scmde As Integer
Dim layerobj As AcadLayer
Dim currentlayername As String
Dim currenttextstyle As String
Dim currentcolor As String


Private Sub CheckBox2_Click() '获取当前模型空间颜色 0-256 颜色索引值
    If CheckBox2.value = True Then
        currentcolor = ThisDrawing.GetVariable("cecolor")
        ThisDrawing.SendCommand "color "
        Label2.Caption = ThisDrawing.GetVariable("cecolor")
        textcolor = ThisDrawing.GetVariable("cecolor")
        If LCase(textcolor) = "bylayer" Then textcolor = "256"
        If LCase(textcolor) = "byblock" Then textcolor = "0"
    End If
End Sub


Private Sub ComboBox1_Click()
    texthight = ComboBox1.Text
    width = texthight * 3.5
End Sub
Private Sub ComboBox2_Click()
    Select Case ComboBox2.Text
        Case "Q"
            ComboBox3.Clear
            With ComboBox3
                .AddItem ""
                .AddItem "al"
                .AddItem "pl"
                .AddItem "dl"
                .AddItem "ml"
                .AddItem "gl"
                .AddItem "eol"
                .AddItem "col"
                .AddItem "kc"
                .AddItem "al+pl"
            End With
            ComboBox4.Clear
            With ComboBox4
                .AddItem ""
                .AddItem "4"
                .AddItem "3"
                .AddItem "2"
                .AddItem "1"
                .AddItem "3-4"
            End With
            ComboBox5.Clear
            ComboBox6.Clear
            ComboBox3.Text = "al+pl"
            ComboBox4.Text = "3-4"
        Case "γ"
            ComboBox3.Clear
            ComboBox4.Clear
            ComboBox5.Clear
            ComboBox6.Clear
            With ComboBox3
                .AddItem ""
                .AddItem "1"
                .AddItem "2"
                .AddItem "3"
            End With
            With ComboBox4
                .AddItem ""
                .AddItem "1"
                .AddItem "2"
                .AddItem "3"
                .AddItem "4"
                .AddItem "5"
                .AddItem "6"
            End With
            ComboBox3.Text = "1"
            ComboBox4.Text = "1"
        Case Else
            ComboBox3.Clear
            ComboBox4.Clear
            ComboBox5.Clear
            ComboBox6.Clear
            With ComboBox4
                .AddItem ""
                .AddItem "1"
                .AddItem "2"
                .AddItem "3"
                .AddItem "1-2"
                .AddItem "2-3"
            End With
            ComboBox3.Text = ""
            ComboBox4.Text = "1"
            ComboBox5.AddItem ""
            ComboBox6.AddItem ""
            Dim i As Integer
            For i = 97 To 122
                ComboBox5.AddItem Chr(i)
                ComboBox6.AddItem Chr(i)
            Next
        End Select
End Sub


Private Sub CommandButton1_Click()
    Me.Hide
    textstring = "Q{\H0.5x;\Sal+pl^3-4;}"
    fuhaocharu textstring
    Me.show
End Sub


Private Sub CommandButton2_Click()
    Me.Hide
    textstring = "Q{\H0.5x;\Sal^3-4;}"
    fuhaocharu textstring
    Me.show
End Sub




Private Sub CommandButton3_Click()
    Me.Hide
    textstring = "Q{\H0.5x;\Spl^3-4;}"
    fuhaocharu textstring
    Me.show
End Sub


Private Sub CommandButton4_Click()
    Me.Hide
    textstring = "Q{\H0.5x;\Sal^4;}"
    fuhaocharu textstring
    Me.show
End Sub


Private Sub CommandButton5_Click()
    Me.Hide
    textstring = "Q{\H0.5x;\Spl^4;}"
    fuhaocharu textstring
    Me.show
End Sub


Private Sub CommandButton6_Click()
    Me.Hide
End Sub


Private Sub CommandButton7_Click()
    Me.Hide
    textstring = ComboBox2.Text & "{\H0.5x;\S" & ComboBox3.Text & "^" _
                                & ComboBox4.Text & ";}" & ComboBox5.Text & ComboBox6.Text
    fuhaocharu textstring
    Me.show
End Sub


Private Sub Label2_Click()
    If CheckBox2.value = True Then
        ThisDrawing.SendCommand "color "
        Label2.Caption = ThisDrawing.GetVariable("cecolor")
        textcolor = ThisDrawing.GetVariable("cecolor")
        If LCase(textcolor) = "bylayer" Then textcolor = "256"
        If LCase(textcolor) = "byblock" Then textcolor = "0"
    End If
End Sub
Private Sub fuhaocharu(str As String)
    On Error Resume Next
    currentlayername = ThisDrawing.ActiveLayer.name
    Set layerobj = ThisDrawing.Layers.Add("年代符号")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    ThisDrawing.ActiveLayer = layerobj
    If CheckBox2.value = True Then
        ThisDrawing.SetVariable "cecolor", textcolor
    Else
        layerobj.color = "256"
        ThisDrawing.SetVariable "cecolor", "256"
    End If
    scmde = ThisDrawing.GetVariable("cmdecho")
    ThisDrawing.SetVariable "cmdecho", 0
    insertbase = ThisDrawing.Utility.GetPoint(, "请选择插入点:")
    insertbase(0) = insertbase(0) - 2
    insertbase(1) = insertbase(1) + 2
    width = texthight * 3.5
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    Set mtextobj = ThisDrawing.ModelSpace.AddMText(insertbase, width, textstring)
    mtextobj.height = texthight
    mtextobj.Update
    '重置系统变量
    With ThisDrawing
        .SetVariable "cmdecho", 0
        .SetVariable "cecolor", currentcolor '恢复绘图颜色
        .SetVariable "textstyle", currenttextstyle
        .ActiveLayer = ThisDrawing.Layers.Item(currentlayername) '恢复图层
    End With
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
    For i = 15 To 95 Step 5  '15---95
        ComboBox1.AddItem i
    Next
    For i = 100 To 1000 Step 50 '100---500
        ComboBox1.AddItem i
    Next
    With ComboBox2
        .AddItem "Q"
        .AddItem "N"
        .AddItem "E"
        .AddItem "K"
        .AddItem "J"
        .AddItem "T"
        .AddItem "P"
        .AddItem "C"
        .AddItem "D"
        .AddItem "S"
        .AddItem "O"
        .AddItem "Z"
        .AddItem "γ"
    End With
    currentcolor = ThisDrawing.GetVariable("cecolor") '获取当前图层颜色
    textcolor = "256"
    texthight = ComboBox1.Text
    width = texthight * 3.5
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

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

cq_qg

感谢大佬的无私分享！

言戲無軍

感谢，不知道对话框有没有

clearup

谢谢大佬分享 学习下  内部代码看起来很复杂，刚接触cad编程，启发很大，