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

yucc

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

我想删除很多同名块中的指定颜色和指定文字，请大神高抬贵手；

2. Sub Example_Select()
   
3.     On Error Resume Next
   
4.     Dim ssetObj As AcadSelectionSet
   
5.     Set ssetObj = ThisDrawing.SelectionSets.Add("sset")
   
6.     If Err Then
   
7.         Err.Clear
   
8.    
   
9.         Set ssetObj = ThisDrawing.SelectionSets.Item("sset")
   
10.     End If
    
11.     ssetObj.Clear
    
12.    
    
13.     Dim mode As Integer
    
14.     Dim gpCode(0) As Integer
    
15.     Dim dataValue(0) As Variant
    
16.    
    
17.     gpCode(0) = 0
    
18.     dataValue(0) = "insert"
    
19.    
    
20.     Dim groupCode As Variant, dataCode As Variant
    
21.     groupCode = gpCode
    
22.     dataCode = dataValue
    
23.    
    
24.     ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
    
25.     Dim i As Integer
    
26.     Dim blkobj As AcadBlock, blkn As String
    
27.     For i = 0 To ssetObj.Count - 1
    
28.       Set blkobj = ThisDrawing.Blocks(ssetObj.Item(i).Name)
    
29. 
    
30.       Ltoc blkobj
    
31.     Next
    
32.     ThisDrawing.Regen acActiveViewport
    
33. End Sub
    
34. 
    
35. 
    
36. Sub Ltoc(blk As AcadBlock)
    
37. Dim Sube As AcadEntity
    
38. For Each Sube In blk
    
39.     Dim tekla As AcadText
    
40.    
    
41.     If Sube.ObjectName = "AcDbBlockReference" Then
    
42.        Ltoc ThisDrawing.Blocks(Sube.Name)
    
43.     ElseIf Sube.ObjectName = "AcDbText" Then
    
44.         Sube.Delete
    
45.     End If
    
46. Next
    
47. 
    
48. End Sub

Sub Example_Select()<br />     On Error Resume Next<br />     Dim ssetObj As AcadSelectionSet<br />     Set ssetObj = ThisDrawing.SelectionSets.Add("sset")<br />     If Err Then<br />         Err.Clear<br />     <br />         Set ssetObj = ThisDrawing.SelectionSets.Item("sset")<br />     End If<br />     ssetObj.Clear<br />     <br />     Dim mode As Integer<br />     Dim gpCode(0) As Integer<br />     Dim dataValue(0) As Variant<br />     <br />     gpCode(0) = 0<br />     dataValue(0) = "insert"<br />     <br />     Dim groupCode As Variant, dataCode As Variant<br />     groupCode = gpCode<br />     dataCode = dataValue<br />     <br />     ssetObj.Select acSelectionSetAll, , , groupCode, dataCode<br />     Dim i As Integer<br />     Dim blkobj As AcadBlock, blkn As String<br />     For i = 0 To ssetObj.Count - 1<br />       Set blkobj = ThisDrawing.Blocks(ssetObj.Item(i).Name)<br /> <br />       Ltoc blkobj<br />     Next<br />     ThisDrawing.Regen acActiveViewport<br /> End Sub<br /> <br /> <br /> Sub Ltoc(blk As AcadBlock)<br /> Dim Sube As AcadEntity<br /> For Each Sube In blk<br />     Dim tekla As AcadText<br />    <br />     If Sube.ObjectName = "AcDbBlockReference" Then<br />        Ltoc ThisDrawing.Blocks(Sube.Name)<br />     ElseIf Sube.ObjectName = "AcDbText" Then<br />         Sube.Delete<br />     End If<br /> Next<br /> <br /> End Sub

mikewolf2k

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

yucc

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

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

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

mikewolf2k

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

yucc

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

2. Sub Ltoc(blk As AcadBlock)
   
3. Dim Sube As AcadEntity
   
4. For Each Sube In blk
   
5.     If Sube.ObjectName = "AcDbBlockReference" Then
   
6.        Ltoc ThisDrawing.Blocks(Sube.Name)
   
7.     ElseIf Sube.ObjectName = "AcDbText" Then
   
8.             If Sube.Color = 5 Or Sube.text = "Tekla structures" Then
   
9.                Sube.Delete
   
10.             End If
    
11.     End If
    
12. Next
    
13. 
    
14. End Sub

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

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

mikewolf2k

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

yucc

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

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

mikewolf2k

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

yucc

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

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

mikewolf2k

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

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