沙漠骆驼工具箱源码-21 插入探坑钻孔（地质相关）

woxing1987

工具条：插入探坑钻孔（地质相关）
1 界面


2 代码如下





'2011年12月6日22:46:59
'探坑和钻孔插入
'by 沙漠骆驼


Dim tkindex As Integer '探坑编号
Dim gaocheng  As Single '高程
Dim shendu As Single       '深度
Dim zigao As Single   '字体高度
Dim insert(2) As Double '各文字及横线的基点对其位置
Dim yscale As Integer       '设置垂直比例
Dim xscale As Integer       '设置水平比例
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
Dim currentlinetype As AcadLineType
Dim currentlineweight As String
Dim tklayer As AcadLayer


Private Sub tankeng(str1 As String) '插入探坑和钻孔
    Me.Hide
    zigao = ComboBox1.Text
    yscale = ComboBox2.Text
    tkindex = ComboBox3.Text
    gaocheng = TextBox2.Text
    shendu = TextBox3.Text
    On Error Resume Next
    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 tklayer = ThisDrawing.Layers.Add(str1)
    With tklayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = tklayer
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ThisDrawing.Preferences.Lineweight = acLnWtByLayer '设置默认线宽
    Dim pt1 As Variant
    pt1 = ThisDrawing.Utility.GetPoint(, "请选取插入点：")
    kong pt1
    insert(0) = pt1(0)
    If zigao < 2 Then
        insert(1) = pt1(1) + 4
    ElseIf zigao <= 3 Then
        insert(1) = pt1(1) + 6
    ElseIf zigao <= 4 Then
        insert(1) = pt1(1) + 8
    Else
        insert(1) = pt1(1) + 10
    End If
    wenzijihengxian str1 ', insert, gaocheng, shendu, zigao
    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 ComboBox3_Click()
    Me.Hide
    Me.show vbModal
End Sub
Private Sub CommandButton1_Click()
    Call tankeng("TK")
End Sub
Private Sub CommandButton2_Click()
    Call tankeng("ZK")
End Sub
Private Sub CommandButton3_Click()
    Call tankeng("KZK")
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 CommandButton4_Click()
    Me.Hide
End Sub


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


Private Sub CommandButton6_Click() '只插入深度
    Me.Hide
    yscale = ComboBox2.Text
    shendu = TextBox3.Text
    On Error Resume Next
    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 tklayer = ThisDrawing.Layers.Add("TK")
    With tklayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = tklayer
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ThisDrawing.Preferences.Lineweight = acLnWtByLayer '设置默认线宽
    Dim pt1 As Variant
    pt1 = ThisDrawing.Utility.GetPoint(, "请选取插入点：")
    kong pt1
   
    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 CommandButton7_Click() '插入平面探坑符号
    Me.Hide
    zigao = ComboBox1.Text
    yscale = ComboBox2.Text
    tkindex = ComboBox3.Text
    gaocheng = TextBox2.Text
    shendu = TextBox3.Text
    On Error Resume Next
    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 tklayer = ThisDrawing.Layers.Add("TKandZK")
    With tklayer
        .LayerOn = True
        .Lock = False
        .Freeze = False
    End With
    ThisDrawing.ActiveLayer = tklayer
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ThisDrawing.Preferences.Lineweight = acLnWtByLayer '设置默认线宽
    Dim pt1 As Variant
    pt1 = ThisDrawing.Utility.GetPoint(, "请选取插入点：")
    insert(0) = pt1(0)
    If zigao < 2 Then
        insert(1) = pt1(1) + 4
    ElseIf zigao <= 3 Then
        insert(1) = pt1(1) + 6
    ElseIf zigao <= 4 Then
        insert(1) = pt1(1) + 8
    Else
        insert(1) = pt1(1) + 10
    End If
    wenzijihengxian "TK"  ', insert, gaocheng, shendu, zigao
    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 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 TextBox3_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 9  '设置字体高度
        ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    ComboBox2.AddItem 1
    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 = 1 To 200  '设置探坑或钻孔编号
        ComboBox3.AddItem Format(i, "00")
    Next
    newtextstyle2 '调用新建字体样式程序
End Sub


Private Sub wenzijihengxian(str1 As String) ',insert As Variant, gaocheng As Single, shendu As Single, zigao As Single)  '画出探坑编号，高程，深度，横线
    Dim tkindextext As AcadText
    Dim gaochengtext As AcadText
    Dim shendutext As AcadText
    Set gaochengtext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), insert, zigao)
    Set tkindextext = ThisDrawing.ModelSpace.AddText(str1 & Format(tkindex, "00"), insert, zigao)
    Set shendutext = ThisDrawing.ModelSpace.AddText(Format(shendu, "0.0"), insert, zigao)
    Dim a1 As Variant
    Dim a2 As Variant
    gaochengtext.GetBoundingBox a1, a2
    Dim l1 As Integer
    l1 = Int(distance(a1, a2)) + 1
    Dim hengxian As AcadLine
    Dim p1(0 To 2) As Double, p2(0 To 2) As Double
    p1(0) = insert(0): p1(1) = insert(1)
    p2(0) = l1 + p1(0): p2(1) = p1(1)
    Set hengxian = ThisDrawing.ModelSpace.AddLine(p1, p2)
    Dim zhongdian(0 To 2) As Double
    zhongdian(0) = p1(0) + l1 / 2: zhongdian(1) = p1(1)
    With gaochengtext
        .Alignment = acAlignmentBottomCenter
        .TextAlignmentPoint = zhongdian
    End With
    With shendutext
        .Alignment = acAlignmentTopCenter
        .TextAlignmentPoint = zhongdian
    End With
    With tkindextext
        .Alignment = acAlignmentMiddleRight
        .TextAlignmentPoint = p1
    End With
End Sub
Private Sub kong(pt As Variant)  '画孔 并进行线段处理
    Dim p1(0 To 2) As Double
    Dim p2(0 To 2) As Double
    Dim p3(0 To 2) As Double
    Dim p4(0 To 2) As Double
    Dim p1p2 As AcadLine
    Dim p4p3 As AcadLine
    On Error Resume Next
    p1(0) = pt(0) - 0.7: p1(1) = pt(1)
    p2(0) = p1(0): p2(1) = p1(1) - shendu * 1000 / yscale
    p3(0) = p2(0) + 1.4: p3(1) = p2(1)
    p4(0) = p3(0): p4(1) = p1(1)
    Set p1p2 = ThisDrawing.ModelSpace.AddLine(p1, p2)
    Set p4p3 = ThisDrawing.ModelSpace.AddLine(p4, p3)
    'ThisDrawing.ModelSpace.AddLine p2, p3
    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 xpt(0 To 2) As Double
    Dim spt(0 To 2) As Double
    xpt(0) = pt(0) - 0.5: xpt(1) = pt(1) - 1
    spt(0) = pt(0) - 0.5: spt(1) = pt(1) + 1
    sset1.Select acSelectionSetCrossing, xpt, spt
    Dim kongpline(0 To 7) As Double  '画孔，用多段线
    If sset1.count = 0 Then
        kongpline(0) = p1p2.startpoint(0): kongpline(1) = p1p2.startpoint(1)
        kongpline(2) = p1p2.endpoint(0): kongpline(3) = p1p2.endpoint(1)
        kongpline(4) = p4p3.endpoint(0): kongpline(5) = p4p3.endpoint(1)
        kongpline(6) = p4p3.startpoint(0): kongpline(7) = p4p3.startpoint(1)
        ThisDrawing.ModelSpace.AddLightWeightPolyline kongpline
        p1p2.Delete
        p4p3.Delete
        Exit Sub
    End If
   
    Dim entity As AcadObject
    Set entity = sset1.Item(0)
    'ThisDrawing.Application.Update
    Dim jiaodian1 As Variant
    Dim jiaodian2 As Variant
    jiaodian1 = entity.IntersectWith(p1p2, acExtendBoth)
    jiaodian2 = entity.IntersectWith(p4p3, acExtendBoth)
    p1p2.startpoint = jiaodian1
    p4p3.startpoint = jiaodian2
    '修剪开始
    If CheckBox1 Then
        Dim det1 As String
        Dim det2 As String
        det1 = axEnt2lspEnt(p1p2)     '选择图元
        det2 = axEnt2lspEnt(p4p3)
        Dim det3 As String
        det3 = GetDoubleEntTable(entity, pt)
        ThisDrawing.SendCommand "(command ""trim"" " & det1 & det2 & e & """" & e & """" & det3 & """"") "
        'ThisDrawing.SendCommand "(command ""trim"" " & det1 & det2 & e & " " & e & " " & det3 & ") "
        '(command "trim"(handent "24D")(handent "24E")""(list(handent "23F")(list 943.811743159217  468.263007701964  0))"") trim
    End If
    kongpline(0) = p1p2.startpoint(0): kongpline(1) = p1p2.startpoint(1)
    kongpline(2) = p1p2.endpoint(0): kongpline(3) = p1p2.endpoint(1)
    kongpline(4) = p4p3.endpoint(0): kongpline(5) = p4p3.endpoint(1)
    kongpline(6) = p4p3.startpoint(0): kongpline(7) = p4p3.startpoint(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline kongpline
    p1p2.Delete
    p4p3.Delete
    quxiao '调用取消命令
End Sub


'求两点之间的距离
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
'转换双元表的函数
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 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