[求助]请问如何实现自动选择图元？谢谢！

12qq21

请问：

根据“使用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

mccad

给定坐标点，要选择到图元，则需要点刚好在图元上， 这样用选择集的SelectAtPoint方法来取得经过 该点的图元。

xiaoyaobest

给两点意见：

1.你自已的指令不要与AUTOCAD自身的指令一致(TRIM是CAD自带的命令代号)，这是很不好的行为，因为你会改变AUTOCAD本身的命令，我们在任何时候都不可以这样做，否则在大范围推广时会备受“功击”，并不是每个人都认为你的指令有意义或比CAD自身的更好用；

2.既然是用VBA做，建议不要在用 SendCommand 和 LISP 的一些方法（特别是SendCommand，能不用尽量不用，尽量用算法解决），原因我在此不累述了，你可以看下明经版主写的一本VBA开发的书。

12qq21

收到 谢谢二位的解答启发 我一一尝试下 谢谢！

12qq21

我进行了一个尝试，可是到那个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