СОРТИРОВКА ВЫДЕЛЕННЫХ ОБЪЕКТОВ ПО SELECTION SET

Option Explicit
Sub SortSelByObjName()
Dim sset As AcadSelectionSet
Dim lwpset As AcadSelectionSet
Dim lnset As AcadSelectionSet
Dim txtset As AcadSelectionSet
Dim mtxset As AcadSelectionSet
Dim blkset As AcadSelectionSet
Dim crcset As AcadSelectionSet
Dim obj(0) As AcadObject
Dim ent As AcadEntity
Dim lwp As AcadLWPolyline
Dim ln As AcadLine
Dim txt As AcadText
Dim mtx As AcadMText
Dim blk As AcadBlockReference
Dim crc As AcadCircle
For Each sset In ThisDrawing.SelectionSets
On Error Resume Next
sset.Delete
Next
If Err Then
Err.Clear
End If
On Error GoTo 0
'//
Set sset = ThisDrawing.PickfirstSelectionSet
sset.Clear
sset.SelectOnScreen
'//
With ThisDrawing.SelectionSets
Set lwpset = .Add("Lwplines")
Set lnset = .Add("Lines")
Set txtset = .Add("Texts")
Set mtxset = .Add("Mtexts")
Set blkset = .Add("Blocks")
Set crcset = .Add("Circles")
End With
'//
For Each ent In sset
If TypeOf ent Is AcadLWPolyline Then
Set obj(0) = ent
lwpset.AddItems obj
ElseIf TypeOf ent Is AcadLine Then
Set obj(0) = ent
lnset.AddItems obj
ElseIf TypeOf ent Is AcadText Then
Set obj(0) = ent
txtset.AddItems obj
ElseIf TypeOf ent Is AcadMText Then
Set obj(0) = ent
mtxset.AddItems obj
ElseIf TypeOf ent Is AcadBlockReference Then
Set obj(0) = ent
blkset.AddItems obj
ElseIf TypeOf ent Is AcadCircle Then
Set obj(0) = ent
crcset.AddItems obj
Else
' do nothing
End If
Next
'//
MsgBox "Total: " & sset.Count & vbCr & _
String(12, "_") & vbCr & vbCr & _
"Plines: " & vbTab & lwpset.Count & vbCr & _
"Lines: " & vbTab & lnset.Count & vbCr & _
"Texts: " & vbTab & txtset.Count & vbCr & _
"Mtexts: " & vbTab & mtxset.Count & vbCr & _
"Blocks: " & vbTab & blkset.Count & vbCr & _
"Circles: " & vbTab & crcset.Count, , "SELECTED:"
'
' rest code goes here
'
' clean up selections
sset.Clear
lwpset.Clear
lnset.Clear
txtset.Clear
mtxset.Clear
blkset.Clear
crcset.Clear
End Sub

Option Explicit
Sub GetAllBlocks()
Dim oSset As AcadSelectionSet
Dim fcode(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfData
Dim oBlkRef As AcadBlockReference
Dim bName As String
Dim countColl As New Collection
Dim n As Long, i As Long
Dim oEnt(0) As AcadObject
On Error GoTo Err_Control
fcode(0) = 0
fdata(0) = "insert"
dxfCode = fcode: dxfData = fdata
'//
On Error Resume Next
Set oSset = ThisDrawing.SelectionSets.Add("$SelBlocks$")
If Err.Number <> 0 Then
Set oSset = ThisDrawing.SelectionSets.Item("$SelBlocks$")
Err.Clear
End If
On Error GoTo 0
' select all blocks
'oSset.Select acSelectionSetAll, , , dxfcode, dxfdata
' or select on screen
oSset.SelectOnScreen dxfCode, dxfData
'//
If Not oSset Is Nothing Then
Do While oSset.Count > 0
bName = oSset.Item(0).Name
'//
For i = oSset.Count - 1 To 0 Step -1
Set oBlkRef = oSset.Item(i)
'//
If StrComp(oBlkRef.Name, bName, vbTextCompare) = 0 Then
n = n + 1
Set oEnt(0) = oBlkRef
oSset.RemoveItems (oEnt)
End If
'//
Next i
'//
Dim tmp(1)
tmp(0) = bName: tmp(1) = n
countColl.Add tmp, bName
n = 0
Loop
End If
'//
' convert collection into dynamic array
If countColl.Count > 0 Then
ReDim countArr(0 To countColl.Count - 1, 0 To 1)
For i = 1 To countColl.Count
countArr(i - 1, 0) = countColl.Item(i)(0)
countArr(i - 1, 1) = countColl.Item(i)(1)
Next i
End If
'// Test:
Dim msg As String
msg = ""
For i = 0 To UBound(countArr, 1)
msg = msg & vbCr & "Blocks " & countArr(i, 0) & " : " & vbTab & countArr(i, 1)
Next i
'//
MsgBox msg, vbInformation, "Count Blocks"
'//
Exit_Here:
ThisDrawing.SelectionSets.Item(ThisDrawing.SelectionSets.Count - 1).Delete
Exit Sub
'//
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
Resume Exit_Here
End Sub