沙漠骆驼工具箱源码-24插入年代符号（地质相关）
工具条：插入年代符号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
大佬的分享精神值得学习+4 感谢大佬的无私分享！ 感谢，不知道对话框有没有 谢谢大佬分享 学习下内部代码看起来很复杂，刚接触cad编程，启发很大，
页:
[1]