Как добраться до существующего BlockReference? (Страница 1 из 2)

 Atts =  MyBlockReference.GetAttributes

Dim MyBlock As AcadBlock
Dim MyBlocks As AcadBlocks
Dim MyBlockReference As AcadBlockReference
Dim Atts As Variant
Public Function SelectMyBlocks(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
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set SelectMyBlocks = objSelSet
End Function
 Public Sub GetMyBlockRefAtts()
  Dim objSelSet As AcadSelectionSet
  Dim objBlkRef As AcadBlockReference
  Dim intType(0) As Integer
  Dim varDat(0) As Variant
  Dim strAttributes As String
  Dim i As Integer
  On Error GoTo Err_Control
    intType(0) = 0
    varDat(0) = "INSERT"
    Set objSelSet = SelectMyBlocks("blocks")
    objSelSet.Select acSelectionSetAll, FilterType:=intType, _
    FilterData:=varDat
    For Each MyBlockReference In objSelSet
      If MyBlockReference.Name = "Corner_Stamp_2" Then
        'MsgBox (MyBlockReference.Name)
        Atts = MyBlockReference.GetAttributes
      End If
    Next MyBlockReference
    'For i = LBound(Atts) To UBound(Atts)
        'strAttributes = strAttributes & "  Tag: " & Atts(i).TagString & "   Value: " & Atts(i).TextString & "    "
        'msg = MsgBox(" Tag: " & Atts(i).TagString & "   Value: " & Atts(i).TextString, , i)
  ' Next
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub

If .EntityName = "AcDbBlockReference" Then 

Public MyBlockReference As AcadBlockReference
Public Atts As Variant
 Public Sub GetMyBlockRefAtts()
  Dim nm As String
    Dim elem As Object
   For Each elem In ThisDrawing.ActiveLayout.Block
      With elem
        If .EntityName Like "AcDbBlockReference" Then
            nm = .Name
            If nm Like ("Corner_Stamp_2") Then
               Atts = elem.GetAttributes
               Exit For
            End If
         End If
      End With
   Next
End Sub

Public Function GetAttrFromFileC(fName As String, BlkName As String, Optional AccuCompare = False) As Collection
 Dim MainDoc As AxDbDocument
 Dim AttrSet As Collection
 Dim Objblk As AcadBlockReference
 Dim objEnt As AcadEntity
 Dim PS As AcadPaperSpace
On Error GoTo Err_Control
 Set MainDoc = IsOpened(fName)
 If MainDoc Is Nothing Then
  Set MainDoc = New AxDbDocument
  MainDoc.Open fName
 End If
 Set PS = MainDoc.PaperSpace
 For Each objEnt In PS
  If TypeName(objEnt) = "IAcadBlockReference" Then
   Set Objblk = objEnt
   If AccuCompare Then
    If StrComp(Objblk.Name, BlkName) = 0 Then
     Set AttrSet = GetBlockAttributesC(Objblk)
    End If
   Else
    If InStr(Objblk.Name, BlkName) <> 0 Then
     Set AttrSet = GetBlockAttributesC(Objblk)
    End If
   End If
  End If
 Next
 Set GetAttrFromFileC = AttrSet
 Set MainDoc = Nothing
 Exit Function
Err_Control:
 MsgBox "Error!" & Err.Number
 Err.Clear
End Function

Set MainDoc = New AxDbDocument