[求助]请问如何实现自动选择图元？谢谢！
请问：根据“使用VBA进行截断(break)和修剪(trim)”，我现在想利用双元素来实现“Trim”，请问怎么实现给定坐标点让CAD自动来选择图元，谢谢！
Sub Trim()
Dim Pnt1 As Variant
Dim entObj1 As AcadEntity
ThisDrawing.Utility.GetEntity entObj1, Pnt1, "选择图元："
Dim det1 As String
det1 = axEnt2lspEnt(entObj1)
Dim Pnt2 As Variant
Dim entObj2 As AcadEntity
ThisDrawing.Utility.GetEntity entObj2, Pnt2, "选择被剪图元："
Dim det2 As String
det2 = GetDoubleEntTable(entObj2, Pnt2)
ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
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)) & "))"
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
给定坐标点，要选择到图元，则需要点刚好在图元上， 这样用选择集的SelectAtPoint方法来取得经过 该点的图元。
给两点意见：
1.你自已的指令不要与AUTOCAD自身的指令一致(TRIM是CAD自带的命令代号)，这是很不好的行为，因为你会改变AUTOCAD本身的命令，我们在任何时候都不可以这样做，否则在大范围推广时会备受“功击”，并不是每个人都认为你的指令有意义或比CAD自身的更好用；
2.既然是用VBA做，建议不要在用 SendCommand 和 LISP 的一些方法（特别是SendCommand，能不用尽量不用，尽量用算法解决），原因我在此不累述了，你可以看下乐筑天下版主写的一本VBA开发的书。
收到 谢谢二位的解答启发 我一一尝试下 谢谢！ 我进行了一个尝试，可是到那个sendcommand命令时总是执行错误，请帮我改改，谢谢！
Dim oAcadApp
Public Sub SelectAtPoint(ByRef SSet As AcadSelectionSet, ByVal pt As Variant)
'SSet.Select acSelectionSetCrossing, pt, pt
Dim pt1 As Variant, pt2 As Variant
Dim objUtility As Object
Set objUtility = oAcadApp.ActiveDocument.Utility ' 必须使用后期绑定
objUtility.CreateTypedArray pt1, vbDouble, pt(0) - 0.0001, pt(1) - 0.0001, pt(2)
objUtility.CreateTypedArray pt2, vbDouble, pt(0) + 0.0001, pt(1) + 0.0001, pt(2)
SSet.Select acSelectionSetCrossing, pt1, pt2
End Sub
Private Sub Command10_Click()
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim pt5(0 To 2) As Double
Dim ss As AcadSelectionSet
Dim dd As AcadSelectionSet
Dim line1, line2, r1
pt1(0) = 0
pt1(1) = 0
pt1(2) = 0
pt5(0) = 5
pt5(1) = 0
pt5(2) = 0
pt2(0) = 10
pt2(1) = 0
pt2(2) = 0
Dim pt3(0 To 2) As Double
Dim pt4(0 To 2) As Double
Dim pt6(0 To 2) As Double
pt3(0) = 1
pt3(1) = 0
pt3(2) = 0
pt4(0) = 1
pt4(1) = 10
pt4(2) = 0
pt6(0) = 1
pt6(1) = 5
pt6(2) = 0
r1 = 1
Set line1 = AddLine(pt1, pt2)
Set line2 = AddLine(pt4, pt3)
Set ss = oAcadApp.ActiveDocument.SelectionSets.Add("d1")
Set dd = oAcadApp.ActiveDocument.SelectionSets.Add("d2")
SelectAtPoint ss, pt5
SelectAtPoint dd, pt6
Dim x1 As AcadLine
Dim x2 As AcadLine
Set x1 = ss.Item(0)
Set x2 = dd.Item(0)
MsgBox "A new SelectionSet called " & ss.Count & " has been added to the SelectionSets collection.", vbInformation, "SelectionSets 示例"
MsgBox "A new SelectionSet called " & dd.Count & " has been added to the SelectionSets collection.", vbInformation, "SelectionSets 示例"
oAcadApp.ActiveDocument.SendCommand "_FILLET" & vbCr & "r" & vbCr & r1 & vbCr & _
"(handent " & Chr(34) & x1.Handle & Chr(34) & ")" & vbCr & "(handent " & Chr(34) & x2.Handle & Chr(34) & ")" & vbCr
End Sub
页:
[1]