创建和填充AutoCAD表

Option Explicit
Sub Blocks_Table()
    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 Atts As Variant
    Dim xStr As String
    Dim yStr As String
    Dim ID As String
    Dim Desc As String
Dim i As Long, j As Long
    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, ID
            .SetCellTextHeight i + 3, j, 0.09375
            .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
            .SetText i + 3, j + 3, Desc
            .SetCellTextHeight i + 3, j + 3, 0.09375
        Next i
        
    .RegenerateTableSuppressed = False
    .Update
    End With
        oTable.MergeCells 1, 2, 0, 0
        oTable.MergeCells 1, 2, 4, 4
        oTable.MergeCells 1, 2, 5, 5
        oTable.MergeCells 1, 1, 1, 3
        
    MsgBox "Yahoooooo!"
End Sub