沙漠骆驼工具箱源码-23插入常用符号（地质相关）

woxing1987

工具条：插入常用符号
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 ptbasepoint  As 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 ptbasepoint  As 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 ptbasepoint  As 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

czb203

        感谢楼主源源不断的分享,论坛因你而精彩!

20060510412

楼主太厉害了，请问vba源代码能不能生成exe，然后用lisp调用哦。
现在vba用起来不太方便了。

lxl217114

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

来武影

同行，感谢分享

czb203

同行，感谢分享

woxing1987

20060510412 发表于 2022-2-22 10:54
楼主太厉害了，请问vba源代码能不能生成exe，然后用lisp调用哦。
现在vba用起来不太方便了。

抱歉，lisp调用vb这一块不熟悉