[求助]求仅选择块内文字的选择集代码

黄玉宏

首先祝大家新年快乐.万事如意.心想事成!

求：１.仅选择模型空间中所有块内文字的选择集代码；２.选择模型空间中除块内文字之外的所有文字的选择集代码。

谢谢

黄玉宏   1.30

黄玉宏

  再次请教各位,请帮忙.

  谢谢!

nhy12345678

第一个问题：答案,TextSS自定义函数来完成，返回仅选择模型空间中所有块内文字的选择集，并从所有块中拷贝出来文字对象

    test为测试子程序，显示所有块内的文字对象个数，检验是正确的

Sub test()
Dim sss As AcadSelectionSet
delSS
Set sss = ThisDrawing.SelectionSets.Add("sss")
Set sss = TextSS
MsgBox sss.count
End Sub

Public Function TextSS() As AcadSelectionSet
Dim ss As AcadSelectionSet
Dim aa(0 To 0) As AcadEntity
Dim ppp As AcadEntity
Dim NewEnt As AcadEntity
Dim expp As Variant
Dim i As Long
Dim ii As Long

Set ss = ThisDrawing.SelectionSets.Add("ss")
   For i = 0 To ThisDrawing.ModelSpace.count - 1 '遍历模型空间所有对象
      Set NewEnt = ThisDrawing.ModelSpace.Item(i)
         If NewEnt.ObjectName = "AcDbBlockReference" Then
             expp = NewEnt.Explode
             For ii = 0 To UBound(expp)
                 Set ppp = expp(ii)
                 If ppp.ObjectName = "AcDbText" Then
                     Set aa(0) = ppp
                     ss.AddItems aa
                 Else
                     ppp.Delete
                 End If
            Next ii
        End If
   Next i
Set TextSS = ss
End Function

Public Function delSS()
Do While ThisDrawing.SelectionSets.count > 0 '=====安全创建选择集
   ThisDrawing.SelectionSets.Item(0).Delete
Loop
End Function

第2给问题就更简单了：答案,TextSS2自定义函数来完成，选择模型空间中除块内文字之外的所有文字的选择集，

     test2为测试子程序，显示所有除块内文字之外的文字对象个数，检验是正确的

Sub test2()
Dim sss As AcadSelectionSet
delSS
Set sss = ThisDrawing.SelectionSets.Add("sss")
Set sss = TextSS2
MsgBox sss.count
End Sub

Public Function TextSS2() As AcadSelectionSet
Dim ss As AcadSelectionSet
Dim aa(0 To 0) As AcadEntity
Dim NewEnt As AcadEntity
Dim i As Long
Set ss = ThisDrawing.SelectionSets.Add("ss")
   For i = 0 To ThisDrawing.ModelSpace.count - 1 '遍历模型空间所有对象
      Set NewEnt = ThisDrawing.ModelSpace.Item(i)
         If NewEnt.ObjectName = "AcDbText" Then
             Set aa(0) = NewEnt
             ss.AddItems aa
         End If
   Next i
Set TextSS2 = ss
End Function

Public Function delSS()
Do While ThisDrawing.SelectionSets.count > 0 '=====安全创建选择集
   ThisDrawing.SelectionSets.Item(0).Delete
Loop
End Function