[新手帮助]将块的所有实例的X，Y输入到新表中

Sub DatumTable()
Dim Block As AcadBlockReference
Dim DatumObj As AcadObject
Dim TableObj As AcadTable
Dim filterType(0) As Integer
Dim filterData(0) As Variant
Dim selSet As AcadSelectionSet
GetEnt: 'Start loop point
    ThisDrawing.Utility.GetEntity DatumObj, ReturnPnt, "Select a block: "
    If DatumObj.ObjectName  "AcDbBlockReference" Then
    MsgBox "The selected object wasn't a block!", vbExclamation
GoTo GetEnt 'Goto loop point
End If
Set selSet = ThisDrawing.SelectionSets. _
             Add("DatumObj")
'Create that Table!
    Dim MyPaperSpace As AcadPaperSpace
    Set MyPaperSpace = ThisDrawing.PaperSpace
    Dim pt(2) As Double
    Dim MyTable As AcadTable
    Set MyTable = MyPaperSpace.AddTable(pt, 1, 2, 3, 4)
    MyTable.RegenerateTableSuppressed = True
    
    
    MyTable.RegenerateTableSuppressed = False
End Sub

object.SetText(row, col, pStr) 

MyTable.SetText(1, 1, Text)

Dim OTbl As AcadTable
Dim vInsPt(2) As Double
Set OTbl = ThisDrawing.ModelSpace.AddTable(vInsPt, 1, 1, 5, 10)

OTbl.SetText 0, 0, "MyText"

    Dim ID As String
    Dim Desc As String

            ID = oBlk.GetAttribute(ID)
            Desc = oBlk.GetAttribute(Desc)

Dim vAtts at Variant
vAtts = oBlk.GetAttributes

Dim I as Integer
Dim oAtt as AcadAttributereference
For I = 0 to UBound(vAtts)
   Set oAtt = vAtts(I)
   Select Case oAtt.TagString
      Case Is = "ID"
         'fill the correct cell with the oAtt.TextString
      Case Is = "DESC"
         'fill the correct cell with the oAtt.TextString
      Case is = "OTHER"
         'fill the correct cell with the oAtt.TextString
     'etc....
   End Select
Next I

Option Explicit
Sub Blocks_Table()
    Dim oAtt As AcadAttributeReference
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oBlk As AcadBlockReference
    Dim varPt As Variant
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim bName As String
    Dim xStr As String
    Dim yStr As String
    Dim vAtts As Variant
    Dim I As Long, j As Long
    Dim C As Integer
    ftype(0) = 0: fdata(0) = "INSERT"
    Dim dxfCode, dxfValue
    dxfCode = ftype: dxfValue = fdata
    With ThisDrawing.SelectionSets
        While .Count > 0
            .Item(0).Delete
        Wend
        Set oSset = .Add("$Blocks$")
    End With
    
    ThisDrawing.ActivePViewport.Display True
    ThisDrawing.ActiveSpace = acModelSpace
    oSset.SelectOnScreen dxfCode, dxfValue
    
    ThisDrawing.ActiveSpace = acPaperSpace
    
    Dim paSpace As AcadPaperSpace
    Set paSpace = ThisDrawing.PaperSpace
    
    varPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Specify insertion point: ")
    Dim oTable As AcadTable
    Set oTable = paSpace.AddTable(varPt, oSset.Count + 3, 6, 0.3, 1.5)
    oTable.TitleSuppressed = False
    oTable.HeaderSuppressed = True
    
    ZoomExtents
    With oTable
    .RegenerateTableSuppressed = True
    
        .SetCellTextHeight I, j, 0.15625
        .SetCellAlignment I, j, acMiddleCenter
        .SetCellType I, j, acTextCell
        .SetText 0, 0, "EQUIPMENT LAYOUT SCHEDULE"
    
        .SetText 1, 0, "ITEM"
        .SetCellTextHeight 1, 0, 0.09375
        .SetText 1, 1, "EQUIPMENT DATUM"
        .SetCellTextHeight 1, 1, 0.09375
        .SetText 1, 4, "DATUM LOCATION"
        .SetCellTextHeight 1, 4, 0.09375
        .SetText 1, 5, "DESCRIPTION"
        .SetCellTextHeight 1, 5, 0.09375
        
        .SetText 2, 1, "N"
        .SetCellTextHeight 2, 1, 0.09375
        .SetText 2, 2, "E"
        .SetCellTextHeight 2, 2, 0.09375
        .SetText 2, 3, "EL"
        .SetCellTextHeight 2, 3, 0.09375
        
        For I = 0 To oSset.Count - 1
            Set oEnt = oSset.Item(I)
            Set oBlk = oEnt
            If oBlk.IsDynamicBlock Then
                bName = oBlk.EffectiveName
            Else
                bName = oBlk.Name
            End If
            xStr = Format(CStr(Round(oBlk.InsertionPoint(1), 3)), "#0.000")
            yStr = Format(CStr(Round(oBlk.InsertionPoint(0), 3)), "#0.000")
            
            .SetCellTextHeight I + 3, j, 0.09375
            .SetCellAlignment I + 3, j, acMiddleCenter
            .SetText I + 3, j + 1, xStr
            .SetCellTextHeight I + 3, j + 1, 0.09375
            .SetText I + 3, j + 2, yStr
            .SetCellTextHeight I + 3, j + 2, 0.09375
    vAtts = oBlk.GetAttributes
        For C = 0 To UBound(vAtts)
           Set oAtt = vAtts(C)
          Select Case oAtt.TagString
              Case Is = "ID"
            .SetText I + 3, 0, oAtt.TextString
            .SetCellTextHeight I + 3, 0, 0.09375
              Case Is = "DESC"
            .SetText I + 3, 5, oAtt.TextString
            .SetCellTextHeight I + 3, 5, 0.09375
              Case Is = "ELEVATION"
            .SetText I + 3, 3, oAtt.TextString
            .SetCellTextHeight I + 3, 3, 0.09375
              Case Is = "DATUMLOC"
            .SetText I + 3, 4, oAtt.TextString
            .SetCellTextHeight I + 3, 4, 0.09375
           End Select
        Next C
        Next I
    
        oTable.MergeCells 1, 2, 0, 0
        oTable.MergeCells 1, 2, 4, 4
        oTable.MergeCells 1, 2, 5, 5
        oTable.MergeCells 1, 1, 1, 3
    
    .RegenerateTableSuppressed = False
    
    .Update
    
    End With
        
    MsgBox "Yahoooooo!"
End Sub