斑竹啊 救救我吧！！！！！！！！！

bluemoon

能不能 把CAD中块的名称删除啊   ？？？怎么用程序实现呢？

mccad

没明白，块的名称删除，那块呢，是否保留？

bluemoon

哦 应该是把知道名称的块删除  
但是我不是用INSERT 插入的
是CAD 中可以查到的
但我用CAD查询查出是ACDBBLOCKREFENCE
对不起 我的问题是太菜了

mccad

你是想将图面上某个名称的图块全部删除，是吗？

bluemoon

是的 斑竹
有什么办法吗？

mccad

2. Sub DelBlkByName()
   
3.     Dim BlockName As String
   
4.     BlockName = "11"  '这里保存着要删除的图块名称
   
5.     Dim ss As AcadSelectionSet
   
6.     Set ss = CreateSelectionSet()
   
7.     Dim fType As Variant
   
8.     Dim fDate As Variant
   
9.     BuildFilter fType, fData, 0, "INSERT", 2, BlockName
   
10.     ss.Select acSelectionSetAll, , , fType, fData
    
11.     Dim Ent As AcadEntity
    
12.     Dim i As Integer
    
13.     i = ss.Count
    
14.     If i > 0 Then
    
15.         For Each Ent In ss
    
16.             Ent.Delete
    
17.         Next
    
18.         Update
    
19.         MsgBox "图形中共有" & i & "个名称为“" & BlockName & "”的图块，都已经被删除了。", , _
    
20.                 "明经通道VBA示例"
    
21.     Else
    
22.         MsgBox "图形中没有名称为“" & BlockName & "”的图块存在。", , _
    
23.                 "明经通道VBA示例"
    
24.     End If
    
25. End Sub
    
26. 
    
27. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    
28. 
    
29.     Dim ss As AcadSelectionSet
    
30.    
    
31.     On Error Resume Next
    
32.     Set ss = ThisDrawing.SelectionSets(ssName)
    
33.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
34.     ss.Clear
    
35.     Set CreateSelectionSet = ss
    
36. 
    
37. End Function
    
38. 
    
39. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
    
40.     Dim fType() As Integer, fData()
    
41.     Dim index As Long, i As Long
    
42.    
    
43.     index = LBound(gCodes) - 1
    
44.         
    
45.     For i = LBound(gCodes) To UBound(gCodes) Step 2
    
46.         index = index + 1
    
47.         ReDim Preserve fType(0 To index)
    
48.         ReDim Preserve fData(0 To index)
    
49.         fType(index) = CInt(gCodes(i))
    
50.         fData(index) = gCodes(i + 1)
    
51.     Next
    
52.     typeArray = fType: dataArray = fData
    
53. End Sub
    

Sub DelBlkByName()<br />     Dim BlockName As String<br />     BlockName = "11"  '这里保存着要删除的图块名称<br />     Dim ss As AcadSelectionSet<br />     Set ss = CreateSelectionSet()<br />     Dim fType As Variant<br />     Dim fDate As Variant<br />     BuildFilter fType, fData, 0, "INSERT", 2, BlockName<br />     ss.Select acSelectionSetAll, , , fType, fData<br />     Dim Ent As AcadEntity<br />     Dim i As Integer<br />     i = ss.Count<br />     If i > 0 Then<br />         For Each Ent In ss<br />             Ent.Delete<br />         Next<br />         Update<br />         MsgBox "图形中共有" & i & "个名称为“" & BlockName & "”的图块，都已经被删除了。", , _<br />                 "明经通道VBA示例"<br />     Else<br />         MsgBox "图形中没有名称为“" & BlockName & "”的图块存在。", , _<br />                 "明经通道VBA示例"<br />     End If<br /> End Sub<br /> <br /> Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br /> <br />     Dim ss As AcadSelectionSet<br />     <br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets(ssName)<br />     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     ss.Clear<br />     Set CreateSelectionSet = ss<br /> <br /> End Function<br /> <br /> Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())<br />     Dim fType() As Integer, fData()<br />     Dim index As Long, i As Long<br />     <br />     index = LBound(gCodes) - 1<br />         <br />     For i = LBound(gCodes) To UBound(gCodes) Step 2<br />         index = index + 1<br />         ReDim Preserve fType(0 To index)<br />         ReDim Preserve fData(0 To index)<br />         fType(index) = CInt(gCodes(i))<br />         fData(index) = gCodes(i + 1)<br />     Next<br />     typeArray = fType: dataArray = fData<br /> End Sub<br />

bluemoon

谢谢斑竹！！！