沙漠骆驼工具箱源码-21 插入探坑钻孔（地质相关）
工具条：插入探坑钻孔（地质相关）1 界面
2 代码如下
'2011年12月6日22:46:59
'探坑和钻孔插入
'by 沙漠骆驼
Dim tkindex As Integer '探坑编号
Dim gaochengAs 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.811743159217468.2630077019640))"") 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
页:
[1]