如何通过vba删除块中的某些对象？

chensj

我想通过vba，在不炸开块的前提下，直接删除块定义中的某些对象，以达到修改块的目的。

另外，能否在不炸开块的前提下获得块中各个对象的相关参数？比如，块中某个圆的半径等。

dong20030432

mccad 发表于 2007-8-20 12:15
图纸除了模型空间、图纸空间外，还有一个是块空间，也就是一个块定义有一个块空间。你可以和操作模型空间一 ...

请问怎么用VBA把选择集中的对象添加到已经建好的块中？请高手赐教！！！

chensj

麻烦各位大侠们指点一二！

英雄无敌

我也想知道，但也许不可能。

在块中增加一个图元很容易，但删除...我没有找到简单的方法，

但在CAD的LSP说明中有一句，可以将想要去掉的实体去掉后，再重新定义这个块，以达到删除图元的目的。

在LISP中，用Nentsel取得块中的图元名，再将块中的所有图元名与之比例，如果相同则过滤之。再重新定义这个块。

在VBA中我却也不知道怎么做。

英雄无敌

刚刚找了找VBA的帮助，找到了个方法GETSUBENTY，我就知道，可以做到了，以下是源程序。

Sub delsubent()
    ' This example prompts the user to select on object on the screen with a mouse click,
    ' and returns some information about the selected object.
   
    Dim Object As AcadEntity
    Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant
    Dim HasContextData As String
   
    On Error GoTo NOT_ENTITY
        Err.Clear
TRYAGAIN:
       
   ' MsgBox "Use the mouse to click on an object in the current drawing after dismissing this dialog box."
       
    ' Get information about selected object
    ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData
   
    ' Process and display selected object properties
If VarType(ContextData) <> vbEmpty Then
      
   Object.Delete
   ThisDrawing.Regen acActiveViewport
End If
GoTo TRYAGAIN

   
NOT_ENTITY:
 
End Sub

chensj

非常感谢英雄无敌！不过GetSubEntity好像只能通过鼠标选择，如果我想让程序后台操作，该如何实现呢？

比如，我想把一个块中的直线全部替换成以各直线为直径的圆。

英雄无敌

用VBA我也不知道，但可以结合VLISP，用(ssget'((0 . "insert")))取得所有的块，但分别取得每个块中的子图元名，如果图元类型是直线，则调用VBA将其删除，然后用ADD方法增加。

mccad

图纸除了模型空间、图纸空间外，还有一个是块空间，也就是一个块定义有一个块空间。你可以和操作模型空间一样来操作块空间，但选择就没有那么自由了，只能使用GetSubEntity方法来选择。

我们在图上所见到的是块参照，通过块参照的块名能够找到其块定义的块空间，再通过块空间来操作块。操作后，记住图纸要重新生成一下就可以了。

英雄无敌

用VBA不知道怎么做，主要是不知道怎么取得块内的子图元，我用VLISP编写了一个，不知对你是否有帮助。

chensj

非常感谢英雄无敌和管理员同志！

看来用VBA，还是无法提取块中的各个对象（子图元）的相关参数。

我对lisp不太懂，而且cad的vba开发也是刚开始摸索，所以看来只能把块参照删除（保存块

参照位置），然后炸开原块，获得各个参数，修改完（包括删除）炸开对象后，再用与原块相同的块参数（如块名、插

入点等）重新定义块，并在原来各个块参照的位置插入新块。这样是可以实现的，只是觉得绕的路是否太多，所以想

知道是否能够得到块中各个对象的参数，比如是否存在某些数据库中；既然连管理员都说不行，看来是真的不行了。

不过还是【衷心】的感谢英雄无敌，和你的lisp程序，等我研究研究lisp和ARX，我想也许能找到更好的办法。

当然也非常感谢管理员同志权威的回答！

mccad

VBA是能做的，怎么会无法提取块中的各个对象呢？在图形中选择块，就可以得到块名，通过块名就可以查到块定义，你可以通过遍历的方法来查看块定义中的所有图元。
如果使用GetSubEntity方法，可以参考以下程序：

2. Sub FixDimText()
3.      Dim Ent As AcadEntity
4.      Dim Pnt As Variant
5.      ThisDrawing.Utility.GetSubEntity Ent, Pnt, transMatrix, contextdata, "选择标注对象："
6.      Dim BlkId As Long
7.      BlkId = Ent.OwnerID
8.      Dim BlkName As String
9.      Dim TextString As String
10.      BlkName = ThisDrawing.ObjectIdToObject(BlkId).Name
11.      If Left(BlkName, 2) = "*D" Then
12.          If Ent.ObjectName = "AcDbMText" Then
13.             TextString = Ent.TextString
14.             If TextString <> "" Then ThisDrawing.ObjectIdToObject(contextdata(0)).TextOverride = TextString
15.          End If
16.      End If
17. End Sub

Sub FixDimText()      Dim Ent As AcadEntity      Dim Pnt As Variant      ThisDrawing.Utility.GetSubEntity Ent, Pnt, transMatrix, contextdata, "选择标注对象："      Dim BlkId As Long      BlkId = Ent.OwnerID      Dim BlkName As String      Dim TextString As String      BlkName = ThisDrawing.ObjectIdToObject(BlkId).Name      If Left(BlkName, 2) = "*D" Then          If Ent.ObjectName = "AcDbMText" Then             TextString = Ent.TextString             If TextString <> "" Then ThisDrawing.ObjectIdToObject(contextdata(0)).TextOverride = TextString          End If      End If End Sub