沙漠骆驼工具箱源码-23插入常用符号（地质相关）
本帖最后由 woxing1987 于 2022-2-21 22:19 编辑工具条：插入常用符号
1 工具条
2代码如下
Dim fuhaolayer As AcadLayer
Dim wenzishuoming As AcadLayer
Dim currenttextstyle As String
Dim currentlayername As String
Dim bili As Double
Dim zigao As Double
Dim wenzi As String
Dim fv1(0 To 2) As Double
Private Sub Label1_Click() '插入指北针
Me.Hide
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
Dim basepoint As Variant
basepoint = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
Dim plinelist(0 To 7) As Double
plinelist(0) = basepoint(0): plinelist(1) = basepoint(1)
plinelist(2) = basepoint(0): plinelist(3) = basepoint(1) + 25
plinelist(4) = basepoint(0) + 6.25: plinelist(5) = basepoint(1) - 19
plinelist(6) = basepoint(0): plinelist(7) = basepoint(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline plinelist
plinelist(0) = basepoint(0): plinelist(1) = basepoint(1)
plinelist(2) = basepoint(0): plinelist(3) = basepoint(1) + 25
plinelist(4) = basepoint(0) - 6.25: plinelist(5) = basepoint(1) - 19
plinelist(6) = basepoint(0): plinelist(7) = basepoint(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline plinelist
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim point4(0 To 2) As Double
' Define the solid
point1(0) = basepoint(0): point1(1) = basepoint(1): point1(2) = 0#
point2(0) = basepoint(0): point2(1) = basepoint(1) + 25: point2(2) = 0#
point3(0) = basepoint(0) + 6.25: point3(1) = basepoint(1) - 19: point3(2) = 0#
point4(0) = basepoint(0): point4(1) = basepoint(1): point4(2) = 0#
ThisDrawing.ModelSpace.AddSolid point1, point2, point3, point4
ThisDrawing.ModelSpace.AddCircle basepoint, 9
ThisDrawing.ModelSpace.AddCircle basepoint, 12
ThisDrawing.ModelSpace.AddCircle basepoint, 12.2
ThisDrawing.ModelSpace.AddCircle basepoint, 12.4
Dim i As Double
bili = ComboBox1.Text
For i = ThisDrawing.ModelSpace.count - 7 To ThisDrawing.ModelSpace.count - 1
ThisDrawing.ModelSpace.Item(i).ScaleEntity basepoint, bili
Next
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label10_Click() ''文字说明加矩形框
Me.Hide
zigao = ComboBox2.Text
wenzi = TextBox1.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
Set wenzishuoming = ThisDrawing.Layers.Add("文字说明")
Dim pt1 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
ThisDrawing.ActiveLayer = wenzishuoming
newtextstyle2 '调用新建字体样式程序
ThisDrawing.SetVariable "textstyle", "wh_lkx"
'Dim textobj As AcadText
Dim textobj As AcadMText
Set textobj = ThisDrawing.ModelSpace.AddMText(pt1, 0, wenzi)
'Set textobj = ThisDrawing.ModelSpace.AddMText(wenzi, pt1, zigao)
With textobj
.height = zigao
'.AttachmentPoint = acAttachmentPointMiddleCenter
End With
Dim box1 As Variant
Dim box2 As Variant
textobj.GetBoundingBox box1, box2
Dim linelist(0 To 9) As Double
box1(0) = box1(0) - 0.5: box1(1) = box1(1) - 0.5
box2(0) = box2(0) + 0.5: box2(1) = box2(1) + 0.5
linelist(0) = box1(0): linelist(1) = box1(1)
linelist(2) = box2(0): linelist(3) = box1(1)
linelist(4) = box2(0): linelist(5) = box2(1)
linelist(6) = box1(0): linelist(7) = box2(1)
linelist(8) = box1(0): linelist(9) = box1(1)
Dim kuang As AcadLWPolyline
Set kuang = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
fv1(0) = (box1(0) + box2(0)) / 2
fv1(1) = (box1(1) + box2(1)) / 2
fv1(2) = 0
textobj.Move fv1, pt1
kuang.Move fv1, pt1
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label11_Click() ''文字说明加矩形框带箭头，还没编好,快了
'问题突然解决了，比较距离大小即可，有时间在编吧
'与矩形框有两个交点，分别计算两点到起点的距离，用距离最短的那个点就行了
Me.Hide
zigao = ComboBox2.Text
wenzi = TextBox1.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
Set wenzishuoming = ThisDrawing.Layers.Add("文字说明")
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
ThisDrawing.ActiveLayer = wenzishuoming
Dim textobj As AcadMText
Set textobj = ThisDrawing.ModelSpace.AddMText(pt2, 0, wenzi)
textobj.height = zigao
Dim box1 As Variant
Dim box2 As Variant
textobj.GetBoundingBox box1, box2
box1(0) = box1(0) - 0.5: box1(1) = box1(1) - 0.5
box2(0) = box2(0) + 0.5: box2(1) = box2(1) + 0.5
If distance(box1, box2) / 2 > distance(pt1, pt2) Then
MsgBox "两点相距太近，请重新操作", vbCritical
Me.show
textobj.Delete
Exit Sub
End If
Dim linelist(0 To 9) As Double '用于求交点
linelist(0) = box1(0): linelist(1) = box1(1)
linelist(2) = box2(0): linelist(3) = box1(1)
linelist(4) = box2(0): linelist(5) = box2(1)
linelist(6) = box1(0): linelist(7) = box2(1)
linelist(8) = box1(0): linelist(9) = box1(1)
Dim kuang As AcadLWPolyline
Set kuang = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
fv1(0) = (box1(0) + box2(0)) / 2
fv1(1) = (box1(1) + box2(1)) / 2
fv1(2) = 0
kuang.Move fv1, pt2
textobj.Move fv1, pt2 '移动到 点pt2 去
Dim line1 As AcadLine
Dim line2 As AcadLine
Set line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Set line2 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim daduandian As Variant
daduandian = line1.IntersectWith(kuang, acExtendNone) '求打断点，共后边修剪使用
Dim jiaodian As Variant
Dim jiaodianzuobiao1(0 To 2) As Double
Dim jiaodianzuobiao2(0 To 2) As Double
Dim kkk1 As Variant
Dim kkk2 As Variant
line1.Rotate pt1, distance(box1, box2) / 7 / line1.length'旋转直线
jiaodian = line1.IntersectWith(kuang, acExtendThisEntity) '延长直线，求交点1
If UBound(jiaodian) > 3 Then'交点大于两个的时候
jiaodianzuobiao1(0) = jiaodian(0)
jiaodianzuobiao1(1) = jiaodian(1)
jiaodianzuobiao1(2) = jiaodian(2)
jiaodianzuobiao2(0) = jiaodian(3)
jiaodianzuobiao2(1) = jiaodian(4)
jiaodianzuobiao2(2) = jiaodian(5)
If distance(jiaodianzuobiao1, pt1) <= distance(jiaodianzuobiao2, pt1) Then
kkk1 = jiaodianzuobiao1
Else
kkk1 = jiaodianzuobiao2
End If
Else'交点为一个的时候
kkk1 = jiaodian
End If
line2.Rotate pt1, distance(box1, box2) / -7 / line2.length '旋转直线
jiaodian = line2.IntersectWith(kuang, acExtendThisEntity) '延长直线，求交点2
If UBound(jiaodian) > 3 Then'交点大于两个的时候
jiaodianzuobiao1(0) = jiaodian(0)
jiaodianzuobiao1(1) = jiaodian(1)
jiaodianzuobiao1(2) = jiaodian(2)
jiaodianzuobiao2(0) = jiaodian(3)
jiaodianzuobiao2(1) = jiaodian(4)
jiaodianzuobiao2(2) = jiaodian(5)
If distance(jiaodianzuobiao1, pt1) <= distance(jiaodianzuobiao2, pt1) Then
kkk2 = jiaodianzuobiao1
Else
kkk2 = jiaodianzuobiao2
End If
Else'交点为一个的时候
kkk2 = jiaodian
End If
line1.endpoint = kkk1
line2.endpoint = kkk2
'下面修剪矩形框
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
Dim det1 As String
Dim det2 As String
det1 = axEnt2lspEnt(line1) '选择图元
det2 = axEnt2lspEnt(line2)
Dim det3 As String
det3 = GetDoubleEntTable(kuang, daduandian)
ThisDrawing.SendCommand "(command ""trim"" " & det1 & det2 & e & """" & e & """" & det3 & """"") "
'ThisDrawing.SendCommand "(command ""trim"" " & det1 & det2 & """" & det3 & """"") "
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label12_Click() '插入大箭头，实体
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
Dim templine As AcadLine
Set templine = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lineangle As Double
lineangle = templine.angle
templine.Delete
Dim linelist(0 To 5) As Double
linelist(0) = pt1(0): linelist(1) = pt1(1)
linelist(2) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 3.5)(0)
linelist(3) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 3.5)(1)
linelist(4) = pt2(0): linelist(5) = pt2(1)
Dim jiantou As AcadLWPolyline
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.SetWidth 0, 0, 2.5
jiantou.SetWidth 1, 1, 1
jiantou.ScaleEntity pt1, bili
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label14_Click() '文字说明，加圆圈
Me.Hide
zigao = ComboBox2.Text
wenzi = TextBox1.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
Set wenzishuoming = ThisDrawing.Layers.Add("文字说明")
Dim pt1 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
ThisDrawing.ActiveLayer = wenzishuoming
newtextstyle2 '调用新建字体样式程序
ThisDrawing.SetVariable "textstyle", "wh_lkx"
Dim textobj As AcadMText
Set textobj = ThisDrawing.ModelSpace.AddMText(pt1, 0, wenzi)
'Set textobj = ThisDrawing.ModelSpace.AddMText(wenzi, pt1, zigao)
With textobj
.height = zigao
.AttachmentPoint = acAttachmentPointMiddleCenter
End With
Dim box1 As Variant
Dim box2 As Variant
textobj.GetBoundingBox box1, box2
Dim zhijing As Double
zhijing = ((box2(0) - box1(0)) ^ 2 + (box2(1) - box1(1)) ^ 2) ^ 0.5 + 1
Dim kuang As AcadCircle
Set kuang = ThisDrawing.ModelSpace.AddCircle(pt1, zhijing / 2)
fv1(0) = (box1(0) + box2(0)) / 2
fv1(1) = (box1(1) + box2(1)) / 2
fv1(2) = 0
textobj.Move fv1, pt1
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label15_Click() '画箭头说明,搞定
Me.Hide
zigao = ComboBox2.Text
wenzi = TextBox1.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
Set wenzishuoming = ThisDrawing.Layers.Add("文字说明")
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
ThisDrawing.ActiveLayer = wenzishuoming
Dim textobj As AcadMText
Set textobj = ThisDrawing.ModelSpace.AddMText(pt2, 0, wenzi)
textobj.height = zigao
Dim box1 As Variant
Dim box2 As Variant
textobj.GetBoundingBox box1, box2
box1(0) = box1(0) - 0.5: box1(1) = box1(1) - 0.5
box2(0) = box2(0) + 0.5: box2(1) = box2(1) + 0.5
Dim templine As AcadLine
Set templine = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lineangle As Double
lineangle = templine.angle
templine.Delete
Dim linelist(0 To 7) As Double '用来画箭头
linelist(0) = pt1(0): linelist(1) = pt1(1)
linelist(2) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 2.5)(0)
linelist(3) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 2.5)(1)
linelist(4) = pt2(0): linelist(5) = pt2(1)
linelist(6) = pt2(0) + box2(0) - box1(0)
linelist(7) = pt2(1)
If pt1(0) > pt2(0) Then
linelist(6) = pt2(0) - box2(0) + box1(0)
linelist(7) = pt2(1)
End If
Dim jiantou As AcadLWPolyline
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.SetWidth 0, 0, 1
textobj.Move box1, pt2'移动到 点pt2 去
If pt1(0) > pt2(0) Then
Dim atob(0 To 2) As Double
atob(0) = linelist(6)
atob(1) = linelist(7)
atob(2) = 0
textobj.Move pt2, atob '在移动一下
End If
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label16_Click() '插入坡度符号
End Sub
Private Sub Label3_Click() '插入小箭头
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
Dim templine As AcadLine
Set templine = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lineangle As Double
lineangle = templine.angle
templine.Delete
Dim linelist(0 To 5) As Double
linelist(0) = pt1(0): linelist(1) = pt1(1)
linelist(2) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 2.5)(0)
linelist(3) = ThisDrawing.Utility.PolarPoint(pt1, lineangle, 2.5)(1)
linelist(4) = pt2(0): linelist(5) = pt2(1)
Dim jiantou As AcadLWPolyline
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.SetWidth 0, 0, 1
jiantou.ScaleEntity pt1, bili
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label5_Click() '插入大箭头,空心的
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
Dim templine As AcadLine
Set templine = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lineangle As Double
Dim linelength As Double
linelength = templine.length
lineangle = templine.angle
templine.Delete
Dim linelist(0 To 15) As Double
linelist(0) = pt1(0): linelist(1) = pt1(1)
linelist(2) = pt1(0) - 2: linelist(3) = pt1(1) + 4.5
linelist(4) = linelist(2) + 1.2: linelist(5) = linelist(3)
linelist(6) = linelist(4): linelist(7) = pt1(1) + linelength
linelist(8) = linelist(6) + 1.6: linelist(9) = linelist(7)
linelist(10) = linelist(8): linelist(11) = pt1(1) + 4.5
linelist(12) = linelist(10) + 1.2: linelist(13) = linelist(11)
linelist(14) = pt1(0): linelist(15) = pt1(1)
Dim jiantou As AcadLWPolyline
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.ScaleEntity pt1, bili
jiantou.Rotate pt1, lineangle - 3.1415926 / 2
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label6_Click() '插入渗水试验
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
newtextstyle2
ThisDrawing.SetVariable "textstyle", "wh_lkx"
Dim ptbasepointAs Variant
Dim bfpt(0 To 2) As Double
ptbasepoint = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
bfpt(0) = ptbasepoint(0) '保存基点
bfpt(1) = ptbasepoint(1)
bfpt(2) = 0
ptbasepoint(0) = ptbasepoint(0) - 6
ptbasepoint(1) = ptbasepoint(1)
Dim templine As AcadLWPolyline
Dim plist(0 To 11) As Double
plist(0) = ptbasepoint(0): plist(1) = ptbasepoint(1)
plist(2) = plist(0) + 2.4: plist(3) = plist(1)
plist(4) = plist(2): plist(5) = plist(3) - 4
plist(6) = plist(4) + 7.2: plist(7) = plist(5)
plist(8) = plist(6): plist(9) = plist(7) + 4
plist(10) = plist(8) + 2.4: plist(11) = plist(9)
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist)
templine.ConstantWidth = 0.5
templine.ScaleEntity bfpt, bili
Dim plist1(0 To 5) As Double
plist1(0) = ptbasepoint(0) + 4: plist1(1) = ptbasepoint(1) + 3.3
plist1(2) = plist1(0): plist1(3) = plist1(1) - 2.5
plist1(4) = plist1(2) - 0.4: plist1(5) = plist1(3) + 0.7
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist1)
templine.ScaleEntity bfpt, bili
plist1(0) = ptbasepoint(0) + 8: plist1(1) = ptbasepoint(1) + 3.3
plist1(2) = plist1(0): plist1(3) = plist1(1) - 2.5
plist1(4) = plist1(2) + 0.4: plist1(5) = plist1(3) + 0.7
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist1)
templine.ScaleEntity bfpt, bili
ptbasepoint(0) = ptbasepoint(0) + 3.6
ptbasepoint(1) = ptbasepoint(1) - 2.8
ptbasepoint(2) = 0
Dim shenshui As AcadText
Set shenshui = ThisDrawing.ModelSpace.AddText("SS1", ptbasepoint, 3)
shenshui.ScaleEntity bfpt, bili
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label7_Click() '插入物探符号
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
newtextstyle2
ThisDrawing.SetVariable "textstyle", "wh_lkx"
Dim ptbasepointAs Variant
Dim bfpt(0 To 2) As Double
ptbasepoint = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
bfpt(0) = ptbasepoint(0) '保存基点
bfpt(1) = ptbasepoint(1)
Dim templine As AcadLWPolyline
Dim plist(0 To 3) As Double
plist(0) = ptbasepoint(0): plist(1) = ptbasepoint(1) + 4
plist(2) = plist(0): plist(3) = plist(1) - 8
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist)
templine.ConstantWidth = 0.4
templine.ScaleEntity bfpt, bili
Dim ptlist1(0 To 5) As Double
ptlist1(0) = ptbasepoint(0) - 0.9: ptlist1(1) = ptbasepoint(1)
ptlist1(2) = ptlist1(0) + 1.8: ptlist1(3) = ptlist1(1)
ptlist1(4) = ptlist1(0): ptlist1(5) = ptlist1(1)
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptlist1)
templine.SetBulge 0, 1
templine.SetBulge 1, 1
templine.ConstantWidth = 1.8
templine.ScaleEntity bfpt, bili
ptbasepoint(0) = ptbasepoint(0) + 2.5
ptbasepoint(1) = ptbasepoint(1) - 1.7
ptbasepoint(2) = 0
Dim shenshui As AcadText
Set shenshui = ThisDrawing.ModelSpace.AddText("WT1", ptbasepoint, 3)
shenshui.ScaleEntity bfpt, bili
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label8_Click() '插入波速测试
Me.Hide
bili = ComboBox1.Text
On Error Resume Next
quxiao '调用取消命令
currentlayername = ThisDrawing.ActiveLayer.name
Set fuhaolayer = ThisDrawing.Layers.Add("常用符号")
ThisDrawing.ActiveLayer = fuhaolayer
newtextstyle2
ThisDrawing.SetVariable "textstyle", "wh_lkx"
Dim ptbasepointAs Variant
ptbasepoint = ThisDrawing.Utility.GetPoint(, "拾取插入点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
Dim templine As AcadLWPolyline
Dim plist(0 To 3) As Double
plist(0) = ptbasepoint(0): plist(1) = ptbasepoint(1)
plist(2) = plist(0) + 5: plist(3) = plist(1)
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist)
templine.ConstantWidth = 0.4
templine.ScaleEntity ptbasepoint, bili
plist(0) = ptbasepoint(0): plist(1) = ptbasepoint(1) - 1.4
plist(2) = plist(0) + 5: plist(3) = plist(1)
Set templine = ThisDrawing.ModelSpace.AddLightWeightPolyline(plist)
templine.ConstantWidth = 0.4
templine.ScaleEntity ptbasepoint, bili
Dim shenshui As AcadText
Set shenshui = ThisDrawing.ModelSpace.AddText("～", ptbasepoint, 5)
shenshui.ScaleEntity ptbasepoint, bili
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
Private Sub Label9_Click()
Me.Hide
zigao = ComboBox2.Text
wenzi = TextBox1.Text
On Error Resume Next
ThisDrawing.SendCommand "whlkx" & vbCr '用来防止按钮坏死，就是不能用了
currentlayername = ThisDrawing.ActiveLayer.name
Set wenzishuoming = ThisDrawing.Layers.Add("文字说明")
Dim pt1 As Variant
Dim pt2 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "拾取第一点:")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "拾取第二点:")
If Err Then
ThisDrawing.Utility.prompt "-----拾取失败，请重新操作------" & vbCrLf
Err.Clear
Me.show
Exit Sub
End If
ThisDrawing.ActiveLayer = wenzishuoming
Dim textobj As AcadMText
Set textobj = ThisDrawing.ModelSpace.AddMText(pt2, 0, wenzi)
'Set textobj = ThisDrawing.ModelSpace.AddMText(wenzi, pt1, zigao)
With textobj
.height = zigao
.AttachmentPoint = acAttachmentPointMiddleCenter
End With
Dim box1 As Variant
Dim box2 As Variant
textobj.GetBoundingBox box1, box2
Dim zhijing As Double
Dim yuanquan As AcadCircle
zhijing = ((box2(0) - box1(0)) ^ 2 + (box2(1) - box1(1)) ^ 2) ^ 0.5 + 1
If zhijing / 2 > distance(pt1, pt2) Then
MsgBox "两点相距太近，请重新操作", vbCritical
Me.show
textobj.Delete
Exit Sub
End If
Set yuanquan = ThisDrawing.ModelSpace.AddCircle(pt2, zhijing / 2)
Dim line1 As AcadLine
Dim line2 As AcadLine
Set line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Set line2 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim jiaodian As Variant
Dim angle1 As Double
Dim angle2 As Double
line1.Rotate pt1, zhijing / 8 / line1.length '旋转直线
jiaodian = line1.IntersectWith(yuanquan, acExtendNone) '求交点1
line1.endpoint = jiaodian
angle1 = angle(pt2, jiaodian)
line2.Rotate pt1, zhijing / -8 / line2.length'旋转直线
jiaodian = line2.IntersectWith(yuanquan, acExtendNone) '求交点2
line2.endpoint = jiaodian
angle2 = angle(pt2, jiaodian)
Dim kuang As AcadArc
Set kuang = ThisDrawing.ModelSpace.AddArc(pt2, zhijing / 2, angle1, angle2)
If kuang.ArcLength < zhijing Then
kuang.Delete
ThisDrawing.ModelSpace.AddArc pt2, zhijing / 2, angle2, angle1
End If
yuanquan.Delete
fv1(0) = (box1(0) + box2(0)) / 2
fv1(1) = (box1(1) + box2(1)) / 2
fv1(2) = 0
textobj.Move fv1, pt2
'恢复图层
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
Me.show
End Sub
'计算角度格式是弧度
Function angle(ByVal p1 As Variant, ByVal p2 As Variant) As Double
angle = ThisDrawing.Utility.AngleFromXAxis(p1, p2)
End Function
'求两点之间的距离
Function distance(sp As Variant, ep As Variant) As Double
Dim dx As Double, dy As Double
dx = sp(0) - ep(0)
dy = sp(1) - ep(1)
distance = Sqr(dx ^ 2 + dy ^ 2)
End Function
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
'转换双元表的函数
Public Function GetDoubleEntTable(entobj As AcadEntity, pnt As Variant) As String
Dim entHandle As String
entHandle = entobj.Handle
GetDoubleEntTable = "(list (handent " & Chr(34) & entHandle & Chr(34) & ")(list " _
& str(pnt(0)) & " " & str(pnt(1)) & " " & str(pnt(2)) & "))"
' GetDoubleEntTable = "(list (handent " & Chr(34) & entHandle & Chr(34) & _
' ")(list " & str(Pnt(0)) & " " & str(Pnt(1)) & str(Pnt(2)) & "))"
End Function
'转换点的函数
Public Function axPoint2lspPoint(pnt As Variant) As String
axPoint2lspPoint = pnt(0) & "," & pnt(1) & "," & pnt(2)
End Function
'转换图元函数
Public Function axEnt2lspEnt(entobj As AcadEntity) As String
Dim entHandle As String
entHandle = entobj.Handle
axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Private Sub UserForm_Initialize()
Dim i As Integer
For i = 0 To 19'设置比例系数
ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
Next
For i = 1 To 19'设置字体高度
ComboBox2.AddItem Format(i / 2 + 0.5, "0.0")
Next
newtextstyle2 '调用新建字体样式程序
ThisDrawing.SetVariable "textstyle", "wh_lkx"
End Sub
感谢楼主源源不断的分享,论坛因你而精彩! 楼主太厉害了，请问vba源代码能不能生成exe，然后用lisp调用哦。
现在vba用起来不太方便了。 大佬的分享精神值得学习+3 同行，感谢分享
同行，感谢分享 20060510412 发表于 2022-2-22 10:54
楼主太厉害了，请问vba源代码能不能生成exe，然后用lisp调用哦。
现在vba用起来不太方便了。
抱歉，lisp调用vb这一块不熟悉{:1_1:}
页:
[1]