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

12qq21 发表于 2009-8-24 22:05:00

请问：根据“使用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 发表于 2009-8-25 06:32:00

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

xiaoyaobest 发表于 2009-8-25 22:19:00

给两点意见：1.你自已的指令不要与AUTOCAD自身的指令一致(TRIM是CAD自带的命令代号)，这是很不好的行为，因为你会改变AUTOCAD本身的命令，我们在任何时候都不可以这样做，否则在大范围推广时会备受“功击”，并不是每个人都认为你的指令有意义或比CAD自身的更好用；2.既然是用VBA做，建议不要在用 SendCommand 和 LISP 的一些方法（特别是SendCommand，能不用尽量不用，尽量用算法解决），原因我在此不累述了，你可以看下明经版主写的一本VBA开发的书。

12qq21 发表于 2009-8-26 21:47:00

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

12qq21 发表于 2009-8-27 00:15:00

我进行了一个尝试，可是到那个sendcommand命令时总是执行错误，请帮我改改，谢谢！Dim oAcadAppPublic 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, pt2End SubPrivate 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]

明经CAD社区's Archiver

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