Hi @Anonymous I made some progress, see attached dwg and code.
The procedure creates 4 different tables inside drawing Linear, Area, Volume (I'm still working on), and count of object.
The code should be more or less linear and flexible, the main issue it's to match the object properties with the correct amount. For Example there is a circle object which I considered circumference as Linear data, so added to linear table, and area to Area Table, may be wrong or correct I don't know.
In addition I excluded from count layer 0, Defpoints and AM_CL the last on related to Construction Line.
If you need you can add or remove more, adding / removing it directly on drawing,
You should check and a give me a feedback.
As you can see from the code the total amount it's made for each layer, the same as before.
Once you run the procedure a group of table will be drawn, so if you made modifications to procedure, before running it again remember to delete the table group placed above yours old one. On the opposite you will have tables overlapped.
If you want to check attached the code (ZIP FIle of .BAS procedure for VBA) and dwg (saved Autocad 2018)
Bye.
Sub Layers_DATA()
Dim LayName() As Variant
Dim ObjectsName() As Variant
Dim LayerSx As AcadLayers
Dim LayerX As AcadLayer
Dim MyObject As AcadEntity
Set LayerSx = ThisDrawing.Layers
LayCount = LayerSx.Count
Dim ptMyTableLinear(0 To 2) As Double
ptMyTableLinear(0) = 3100
ptMyTableLinear(1) = 22000
ptMyTableLinear(2) = 0
Dim ptMyTableArea(0 To 2) As Double
ptMyTableArea(0) = 3100 * 2
ptMyTableArea(1) = 22000
ptMyTableArea(2) = 0
Dim ptMyTableVolume(0 To 2) As Double
ptMyTableVolume(0) = 3100 * 3
ptMyTableVolume(1) = 22000
ptMyTableVolume(2) = 0
Dim ptMyTableTotObj(0 To 2) As Double
ptMyTableTotObj(0) = 3100 * 4
ptMyTableTotObj(1) = 22000
ptMyTableTotObj(2) = 0
Dim MyTableLinear As AcadTable
Dim MyTableArea As AcadTable
Dim MyTableVolume As AcadTable
Dim MyTableTotObj As AcadTable
Dim MyModelSpace As AcadModelSpace
Set MyModelSpace = ThisDrawing.ModelSpace
'AddTable(InsertionPoint, NumRows, NumColumns, RowHeight, ColWidth)
Set MyTableLinear = MyModelSpace.AddTable(ptMyTableLinear, LayCount, 2, 300, 1550)
Set MyTableArea = MyModelSpace.AddTable(ptMyTableArea, LayCount, 2, 300, 1550)
Set MyTableVolume = MyModelSpace.AddTable(ptMyTableVolume, LayCount, 2, 300, 1550)
Set MyTableTotObj = MyModelSpace.AddTable(ptMyTableTotObj, LayCount, 2, 300, 1550)
'object.SetCellValue row, col, val
MyTableLinear.SetCellValue 0, 0, "LINEAR"
MyTableLinear.SetCellValue 1, 0, "LAYERS"
MyTableLinear.SetCellValue 1, 1, "VALUE"
MyTableArea.SetCellValue 0, 0, "AREA"
MyTableArea.SetCellValue 1, 0, "LAYERS"
MyTableArea.SetCellValue 1, 1, "VALUE"
MyTableVolume.SetCellValue 0, 0, "VOLUME"
MyTableVolume.SetCellValue 1, 0, "LAYERS"
MyTableVolume.SetCellValue 1, 1, "VALUE"
MyTableTotObj.SetCellValue 0, 0, "TOT. OBJ."
MyTableTotObj.SetCellValue 1, 0, "LAYERS"
MyTableTotObj.SetCellValue 1, 1, "VALUE"
Row = 2
For Each LayerX In LayerSx
If LayerX.Name <> "0" And LayerX.Name <> "Defpoints" And LayerX.Name <> "AM_CL" Then
MyTableLinear.SetCellValue Row, 0, LayerX.Name
MyTableArea.SetCellValue Row, 0, LayerX.Name
MyTableVolume.SetCellValue Row, 0, LayerX.Name
MyTableTotObj.SetCellValue Row, 0, LayerX.Name
Row = Row + 1
End If
Next
Count = 1
Count1 = 1
For Each LayerX In LayerSx
If LayerX.Name <> "0" And LayerX.Name <> "Defpoints" And LayerX.Name <> "AM_CL" Then
ReDim Preserve LayName(Count)
LayName(Count) = LayerX.Name
Count = Count + 1
For Each MyObject In ThisDrawing.ModelSpace
If MyObject.Layer = LayerX.Name Then
ReDim Preserve ObjectsName(Count1)
ObjectsName(Count1) = MyObject.ObjectName
Select Case ObjectsName(Count1)
Case "AcDbPolyline"
If MyObject.Closed = True Then
TotalArea = TotalArea + MyObject.Area
For Row = 2 To LayCount
If MyTableArea.GetCellValue(Row, 0) = LayerX.Name Then
MyTableArea.SetCellValue Row, 1, FormatNumber(TotalArea, 2)
End If
Next Row
End If
TotalLength = TotalLength + MyObject.Length
For Row = 2 To LayCount
If MyTableLinear.GetCellValue(Row, 0) = LayerX.Name Then
MyTableLinear.SetCellValue Row, 1, FormatNumber(TotalLength, 2)
End If
Next Row
Case "AcDbLine"
TotalLength = TotalLength + MyObject.Length
For Row = 2 To LayCount
If MyTableLinear.GetCellValue(Row, 0) = LayerX.Name Then
MyTableLinear.SetCellValue Row, 1, FormatNumber(TotalLength, 2)
End If
Next Row
Case "AcDbRegion"
TotalLength = TotalLength + MyObject.Perimeter
For Row = 2 To LayCount
If MyTableLinear.GetCellValue(Row, 0) = LayerX.Name Then
MyTableLinear.SetCellValue Row, 1, FormatNumber(TotalLength, 2)
End If
Next Row
TotalArea = TotalArea + MyObject.Area
For Row = 2 To LayCount
If MyTableArea.GetCellValue(Row, 0) = LayerX.Name Then
MyTableArea.SetCellValue Row, 1, FormatNumber(TotalArea, 2)
End If
Next Row
Case "AcDbCircle"
TotalLength = TotalLength + MyObject.Circumference
For Row = 2 To LayCount
If MyTableLinear.GetCellValue(Row, 0) = LayerX.Name Then
MyTableLinear.SetCellValue Row, 1, FormatNumber(TotalLength, 2)
End If
Next Row
TotalArea = TotalArea + MyObject.Area
For Row = 2 To LayCount
If MyTableArea.GetCellValue(Row, 0) = LayerX.Name Then
MyTableArea.SetCellValue Row, 1, FormatNumber(TotalArea, 2)
End If
Next Row
Case "AcDb3dSolid"
Debug.Print "PIPO"
End Select
For Row = 2 To LayCount
If MyTableTotObj.GetCellValue(Row, 0) = LayerX.Name Then
MyTableTotObj.SetCellValue Row, 1, FormatNumber(Count1, 2)
End If
Next Row
Count1 = Count1 + 1
End If
Next
End If
TotalLength = 0
TotalArea = 0
Count1 = 0
Row = 2
Next
End Sub
