[sergtranes]

известная процедура выбора блоков по имени:

Процедура GetBlkRefs добавляет в созданный ранее набор objSelSet все вставленные в чертеж блоки с именем strBlkName

Код:

[Выделить все]

Option Explicit

'Begin Code Block
Public Sub GetBlkRefs(strBlkName As String, objSelSet As AcadSelectionSet)
  Dim objBlk As AcadBlock
  Dim colBlks As AcadBlocks
  Dim objBlkRefs As AcadBlockReference
  Dim varData(0) As Variant
  Dim intData(0) As Integer
  varData(0) = strBlkName
  intData(0) = 2
  objSelSet.Select acSelectionSetAll, , , intData, varData
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = strName Then
      ThisDrawing.SelectionSets.Item(strName).Delete
      Exit For
    End If
  Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function

'Now you can test it
Public Sub TestRefs()
  Dim objSS As AcadSelectionSet
  Dim objblkRef As AcadBlockReference
  
  Set objSS = vbdPowerSet("llama")
  ' Замените имя блока "test" на любое другое,
  ' определенное в теущем чертеже
  ' Хотя бы один блок с таким именем должен быть вставлен
  GetBlkRefs "test", objSS
  For Each objblkRef In objSS
    objSS.Highlight True
  Next objblkRef
End Sub

не собирает динамические блоки
?? как изменить фильтр ???

[Shraybicus]

Как-то так

Код:

[Выделить все]

Public Sub publicar()
    Dim objSS As AcadSelectionSet
    Dim varPnt1 As Variant
    Dim varPnt2 As Variant
    Dim strOpt As String
    Dim lngMode As Long
    
    Dim intCodes(0) As Integer
    Dim varCodeValues(0) As Variant
    intCodes(0) = 0
    varCodeValues(0) = "insert"
    
    On Error GoTo Done
    With ThisDrawing.Utility
        '' get input for mode
        .InitializeUserInput 1, "Crossing All"
        strOpt = .GetKeyword(vbCr & _
        "Select [Crossing/All] <all>: ")
        '' create a new selectionset
        Set objSS = ThisDrawing.SelectionSets.Add("TestSelectSS")
        '' if it's crossing, get the points
        If "Crossing" = strOpt Then
            '' convert keyword into mode
            lngMode = acSelectionSetCrossing
            '' get first point
            .InitializeUserInput 1
            varPnt1 = .GetPoint(, vbCr & "Pick the first corner: ")
            '' get corner, using dashed lines if window
            .InitializeUserInput 1 + IIf("Crossing" = strOpt, 32, 0)
            varPnt2 = .GetCorner(varPnt1, vbCr & "Pick other corner: ")
            '' select entities using points
            objSS.Select lngMode, varPnt1, varPnt2, _
            intCodes, varCodeValues
        Else
            '' convert keyword into mode
            lngMode = acSelectionSetAll
            '' select entities using mode
            objSS.Select lngMode, , , _
            intCodes, varCodeValues
        End If

        Dim index As Integer
        Dim oBlockRef As AcadBlockReference
 
        ' Look a EffectiveName of block
        For index = 0 To objSS.count - 1
            
            Set oBlockRef = objSS.Item(index)
            oBlockRef.Highlight True
            MsgBox "EffectiveName: " & oBlockRef.EffectiveName
            oBlockRef.Highlight False
            
        Next index
        
        '' highlight the selected entities
        objSS.Highlight True
        '' pause for the user
        .GetString False, vbCr & "Enter to continue"
        '' unhighlight the entities
        objSS.Highlight False
    End With
Done:
    '' if the selectionset was created, delete it
    If Not objSS Is Nothing Then
    objSS.Delete
    End If
    

    
End Sub

[sergtranes]

спасибо большое - помогло
oBlockRef.EffectiveName