社区 › VBA/VB/ActiveX/API 编程技术 › 删除很多同名块中的指定颜色和指定文字

yucc 发表于 2016-1-28 20:29:24

删除很多同名块中的指定颜色和指定文字

以下是借用坛里大神的代码，在此感谢；

我想删除很多同名块中的指定颜色和指定文字，请大神高抬贵手；Sub Example_Select()
    On Error Resume Next
    Dim ssetObj As AcadSelectionSet
    Set ssetObj = ThisDrawing.SelectionSets.Add("sset")
    If Err Then
      Err.Clear
   
      Set ssetObj = ThisDrawing.SelectionSets.Item("sset")
    End If
    ssetObj.Clear
   
    Dim mode As Integer
    Dim gpCode(0) As Integer
    Dim dataValue(0) As Variant
   
    gpCode(0) = 0
    dataValue(0) = "insert"
   
    Dim groupCode As Variant, dataCode As Variant
    groupCode = gpCode
    dataCode = dataValue
   
    ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
    Dim i As Integer
    Dim blkobj As AcadBlock, blkn As String
    For i = 0 To ssetObj.Count - 1
      Set blkobj = ThisDrawing.Blocks(ssetObj.Item(i).Name)

      Ltoc blkobj
    Next
    ThisDrawing.Regen acActiveViewport
End Sub


Sub Ltoc(blk As AcadBlock)
Dim Sube As AcadEntity
For Each Sube In blk
    Dim tekla As AcadText
   
    If Sube.ObjectName = "AcDbBlockReference" Then
       Ltoc ThisDrawing.Blocks(Sube.Name)
    ElseIf Sube.ObjectName = "AcDbText" Then
      Sube.Delete
    End If
Next

End Sub

mikewolf2k 发表于 2016-1-29 08:56:46

代码是删除块中所有文字吧？如果要删除指定颜色和内容的文字，在sube.delete前加一个判断，满足就删除。

yucc 发表于 2016-1-29 09:48:03

mikewolf2k 发表于 2016-1-29 08:56 static/image/common/back.gif
代码是删除块中所有文字吧？如果要删除指定颜色和内容的文字，在sube.delete前加一个判断，满足就删除。

对的，代码是删文字的，；

原理捋顺了，删之前是判断sube吗？这个时候sube应该赋予什么属性？请指点

mikewolf2k 发表于 2016-1-29 10:05:48

Sube.ObjectName = "AcDbText"
这里确定了sube是个text，源代码后面直接就删除了Sube.Delete。你要加条件的话，就再加个判断，比如if sube.color=1 or sube.text="aa" then sube.delete

yucc 发表于 2016-1-29 10:26:39

mikewolf2k 发表于 2016-1-29 10:05 static/image/common/back.gif
Sube.ObjectName = "AcDbText"
这里确定了sube是个text，源代码后面直接就删除了Sube.Delete。你要加条件的 ...

Sub Ltoc(blk As AcadBlock)
Dim Sube As AcadEntity
For Each Sube In blk
    If Sube.ObjectName = "AcDbBlockReference" Then
       Ltoc ThisDrawing.Blocks(Sube.Name)
    ElseIf Sube.ObjectName = "AcDbText" Then
            If Sube.Color = 5 Or Sube.text = "Tekla structures" Then
               Sube.Delete
            End If
    End If
Next

End Sub这样增加判断后，任何内容都没删掉，If Sube.Color = 5 Or Sube.text = "Tekla structures"    应该是这段没将判断纳入选择集吧？

mikewolf2k 发表于 2016-1-29 10:46:47

如果没记错的话，ThisDrawing.Blocks(Sube.Name)返回的是“源”块，也就是你输入i能选择的本文件存在的块，跟是不是插入毫无关系。
要修改插入的块，得遍历所有的块元素，然后再做。
你试下插入新块，看是不是符合内容的text已经被删除了？

yucc 发表于 2016-1-29 11:21:50

mikewolf2k 发表于 2016-1-29 10:46 static/image/common/back.gif
如果没记错的话，ThisDrawing.Blocks(Sube.Name)返回的是“源”块，也就是你输入i能选择的本文件存在的块， ...

按理说ElseIf Sube.ObjectName = "AcDbText" Then已经判断为文字了，为什么接着判断就不对了？
这个就有点迷糊了，还请能小敲一段

mikewolf2k 发表于 2016-1-29 11:31:42

前面ThisDrawing.Blocks(Sube.Name)返回的是“源”块，所以改的也是“源”块的内容，图纸上任何东西都没改，当然看不出任何变化。说了你插入下新块看看。

yucc 发表于 2016-1-29 12:50:42

mikewolf2k 发表于 2016-1-29 11:31 static/image/common/back.gif
前面ThisDrawing.Blocks(Sube.Name)返回的是“源”块，所以改的也是“源”块的内容，图纸上任何东西都没改， ...

这个有点不会了，4,5年没碰，忘了不少，希望您能帮个忙

mikewolf2k 发表于 2016-1-29 13:17:15

yucc 发表于 2016-1-29 12:50 static/image/common/back.gif
这个有点不会了，4,5年没碰，忘了不少，希望您能帮个忙

做个过滤器，遍历所有的块，然后在这个集合中的块元素去做上面那些事。不要用ThisDrawing.Blocks(Sube.Name)。

查看完整版本: 删除很多同名块中的指定颜色和指定文字