How to I get Layer Names (Remove/No Duplicates) in my SelectionSet of Objects

[Anonymous]

Good Day, I have codes that computes a total length and tabulates it in table, however I keep getting duplicate layer names. How do I filter/remove the duplicates.

Here's my code so far:

Private Sub COMPUTE_Click()

Dim ASelSet As AcadSelectionSet
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant

On Error Resume Next
Set ASelSet = ThisDrawing.SelectionSets.Add("SS")
FilterType(0) = 0
FilterData(0) = "LINE"
FilterType(1) = 8
FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE"
If Err.Number <> 0 Then
Set ASelSet = ThisDrawing.SelectionSets.Item("SS")
FilterType(0) = 0
FilterData(0) = "LINE"
FilterType(1) = 8
FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE"
End If
ASelSet.Clear
ASelSet.SelectOnScreen FilterType, FilterData

Dim SelInsPoint As Variant
SelInsPoint = ThisDrawing.Utility.GetPoint(, "Select Insertion Point of Table: ")

Dim LayName() As Variant
Dim LayersX As AcadLayers
Dim LayerX As AcadLayer
Dim LayCount As Integer

Set LayersX = ThisDrawing.LAYERS        '----> these part gives my table many blanks, it count the total layers
LayCount = LayersX.count                         '----> how do I count the layer of my selection objects only?

Dim MyModelSpace As AcadModelSpace
Set MyModelSpace = ThisDrawing.ModelSpace

Dim MyTableLinear As AcadTable
Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, LayCount, 2, 500, 8000)

MyTableLinear.SetCellValue 0, 0, "LINEAR"
MyTableLinear.SetCellValue 1, 0, "LAYERS"
MyTableLinear.SetCellValue 1, 1, "LENGTH"

Dim OBJECT As AcadObject
Dim Row As Integer
Row = 2

For Each OBJECT In ASelSet                                                  '----> these parts gives me the duplicate layer names
MyTableLinear.SetCellValue Row, 0, OBJECT.Layer         '----> when I select all the items/objects/entity that
Row = Row + 1                                                                           '----> I want to compute, each object layer populate in Table
Next                                                                                              '---->I want to remove the duplicates

End Sub

[grobnik]

Hi @Anonymous ,

I suggest to scan the cell in the Table, before writing LAYER NAME value inside, and check if the cella value (layer name) exist, If it already exist increase the count of existing object's layer, if not, write a new row with layer name and count for next object inspection in the selection.

The amount of row could be determinate by count of not duplicated object's layer.

[Anonymous]

@ grobnik

 Thanks for feedback sir, but do you mind giving me sample of codes for scanning/checking. I'm still new to vba autocad. Thanks again

[grobnik]

here attached the code and sample drawing with lines on different layers, and different lengths, just to test the total lengths.

I added also the object count per each layer, not shown in the table.

Table will have fixed number of rows and columns (I didn't any modification on this part) but it's easy to do.

See the code and let us know

If you want to add more layers, duplicate the variable declaration and code structure.

Several time ago I already sent you a procedure like this.... I'll check.

Dim OBJECT As AcadObject
Dim CountObJYell As Integer
Dim CountObJRed As Integer
Dim CountObJCyan As Integer
Dim CountObJGreen As Integer
Dim CountObJBlue As Integer
Dim CountObJORANGE As Integer
 CountObJYell = 0
 CountObJRed = 0
 CountObJCyan = 0
 CountObJGreen = 0
 CountObJBlue = 0
 CountObJORANGE = 0
Dim ToTLengthObjYell As Long
Dim ToTLengthObjRed As Long
Dim ToTLengthObjCyan As Long
Dim ToTLengthObjGreen As Long
Dim ToTLengthObjBlue As Long
Dim ToTLengthObjORANGE As Long


'Dim Row As Integer
'Row = 2

'Yellow,Red,Cyan,Green,Blue,ORANGE
For Each OBJECT In ASelSet                                                  '----> these parts gives me the duplicate layer names
Select Case OBJECT.Layer

Case "Yellow"
    CountObJYell = CountObJYell + 1
    MyTableLinear.SetCellValue 2, 0, OBJECT.Layer
    ToTLengthObjYell = ToTLengthObjYell + OBJECT.Length
    MyTableLinear.SetCellValue 2, 1, ToTLengthObjYell

Case "Red"
    CountObJRed = CountObJRed + 1
    MyTableLinear.SetCellValue 3, 0, OBJECT.Layer
    ToTLengthObjRed = ToTLengthObjRed + OBJECT.Length
    MyTableLinear.SetCellValue 3, 1, ToTLengthObjRed

Case "Cyan"
    CountObJCyan = CountObJCyan + 1
    MyTableLinear.SetCellValue 4, 0, OBJECT.Layer
    ToTLengthObjCyan = ToTLengthObjCyan + OBJECT.Length
    MyTableLinear.SetCellValue 4, 1, ToTLengthObjCyan

Case "Green"
    CountObJGreen = CountObJGreen + 1
    MyTableLinear.SetCellValue 5, 0, OBJECT.Layer
    ToTLengthObjGreen = ToTLengthObjGreen + OBJECT.Length
    MyTableLinear.SetCellValue 5, 1, ToTLengthObjGreen

Case "Blue"
    CountObJBlue = CountObJBlue + 1
    MyTableLinear.SetCellValue 6, 0, OBJECT.Layer
    ToTLengthObjBlue = ToTLengthObjBlue + OBJECT.Length
    MyTableLinear.SetCellValue 6, 1, ToTLengthObjBlue

Case "ORANGE"
    CountObJORANGE = CountObJORANGE + 1
    MyTableLinear.SetCellValue 7, 0, OBJECT.Layer
    ToTLengthObjORANGE = ToTLengthObjORANGE + OBJECT.Length
    MyTableLinear.SetCellValue 7, 1, ToTLengthObjORANGE

End Select

Next         '---->I want to remove the duplicates

End Sub

Bye

[Anonymous]

@grobnik  thanks, here's what I got sir : 

1st table gives me blanks if I only pick what I need to compute (I still don't know how to remove all the blanks till bottom)

2nd table doesn't compute the other shapes (circle.circumference , arc.ArcLength)

my other concerns is: I have too many lines/shapes with different layer names each (mostly around 100 layers)

the codes you gave me from my other post are very handful. I was able to learn and apply most of it. However, I really need to use SELECTIONSET and just tabulate the needed layer names per groupings of calculations.

Thanks again sir.

[grobnik]

Hi @Anonymous 

I do not understand, now you are showing and talking about 2 tables instead 1 of previous message.

The last code I gave you yesterday it's working, for empty space in the table you have to define the number of row before inserting it. Of course the objects which I drawn are Line, because you indicated LINE in your selection set filter. If you need something else you have refine your selection set adding with AND or OR logic function all other objects you need to select.

You already know the amount of layer which do you want to select by selection set, so you can fix before inserting the table object in the drawing the row, and the columns.

For the separate table, with amount of object per each layer, and empty rows, I guess the objects are not only LINE because I tried with increasing the first table with a 3rd column including the amount of objects per layer and it's working (see image below).

I used this code with placing a comment on your one (I just replaced the LayCount with a fixed number):

'Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, LayCount, 2, 500, 8000)
Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, 7, 3, 500, 8000)

As you can see, I created a Table of only 7 rows, and 3 columns (3rd column for total amount of objects per each layer)

I didn't use the LayCount variable, because it's contains all drawing layers, instead only ones you selected in Filterdata for SelectionSet.

 FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE"

So the main issue, for amount count will be that objects your are counting are not only LINE, so due to has been assigned one fixed row per each layer, means that you are counting something else. See below picture, attached dwg and code here attached again.

I'll try to create a second Table only for Objects Count.

Bye

[Anonymous]

@grobnik 

thanks, I got the arc/circumference by adding 

FilterData(0) = "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"

ToTLengthObjCyan = ToTLengthObjCyan + OBJECT.ArcLength
ToTLengthObjCyan = ToTLengthObjCyan + OBJECT.Circumference

the second table gives me no blanks if all my layers in my filters are selected.

the first table gives me blanks because I didn't include the others in my selectionset

if these are my filter layers and set row cell each:

FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE,8 mm RSB by 6 m,10 mm RSB by 6 m,12 mm RSB by 6 m,16 mm RSB by 6 m,20 mm RSB by 6 m,25 mm RSB by 6 m,28 mm RSB by 6 m,32 mm RSB by 6 m,8 mm RSB by 7.5 m,10 mm RSB by 7.5 m,12 mm RSB by 7.5 m,16 mm RSB by 7.5 m,20 mm RSB by 7.5 m,25 mm RSB by 7.5 m,28 mm RSB by 7.5 m,32 mm RSB by 7.5 m,8 mm RSB by 9 m,10 mm RSB by 9 m,12 mm RSB by 9 m,16 mm RSB by 9 m,20 mm RSB by 9 m,25 mm RSB by 9 m,28 mm RSB by 9 m,32 mm RSB by 9 m,8 mm RSB by 10.5 m,10 mm RSB by 10.5 m,12 mm RSB by 10.5 m,16 mm RSB by 10.5 m,20 mm RSB by 10.5 m,25 mm RSB by 10.5 m,28 mm RSB by 10.5 m,32 mm RSB by 10.5 m,8 mm RSB by 12 m,10 mm RSB by 12 m,12 mm RSB by 12 m,16 mm RSB by 12 m,20 mm RSB by 12 m,25 mm RSB by 12 m,28 mm RSB by 12 m,32 mm RSB by 12 m"

And I only want to compute some Red and some 32 mm RSB by 12 m, it will give me a table with full of blanks 

 

Thanks for helping sir

[grobnik]

Hi @Anonymous ,

I' m working on, the trick will be to add rows to the table, data type, only after the effective count of layers of selected objects, and not determinate an amount of row before knowing the amount of layers relative to selected objects, as your code is doing now.

Whenever the procedure, as sample, will be tested I'll share with you.

[grobnik]

Hi @Anonymous 

here attached the project reviewed.

Here below the main code details, your selection set will be still used, but as I explained before the Table Rows will be added only if there are objects on such layer.

Table will be composed by 3 columns, LAYER, LENGHT, COUNT OBJECTS x LAYER. If you need to separate the TABLES you can modify the code following the same structure.

Of course the procedure could be optimized if you have a lot layers.

For your better understand the previous section where the value will be entered in the table cells, has been commented by "  '  ".

Let us know.

EXTRACTED CODE:

'....
For Each OBJECT In ASelSet
Select Case OBJECT.Layer

Case "Yellow"
    CountObJYell = CountObJYell + 1
    'MyTableLinear.SetCellValue 2, 2, CountObJYell
    'MyTableLinear.SetCellValue 2, 0, OBJECT.Layer
    ToTLengthObjYell = ToTLengthObjYell + OBJECT.Length
    'MyTableLinear.SetCellValue 2, 1, ToTLengthObjYell
    LabLY_Yellow = "Yellow"
Case "Red"
    CountObJRed = CountObJRed + 1
    'MyTableLinear.SetCellValue 3, 2, CountObJRed
   ' MyTableLinear.SetCellValue 3, 0, OBJECT.Layer
    ToTLengthObjRed = ToTLengthObjRed + OBJECT.Length
   ' MyTableLinear.SetCellValue 3, 1, ToTLengthObjRed
    LabLY_Red = "Red"

Case "Cyan"
    CountObJCyan = CountObJCyan + 1
    'MyTableLinear.SetCellValue 4, 2, CountObJCyan
    'MyTableLinear.SetCellValue 4, 0, OBJECT.Layer
    ToTLengthObjCyan = ToTLengthObjCyan + OBJECT.Length
    'MyTableLinear.SetCellValue 4, 1, ToTLengthObjCyan
    LabLY_Cyan = "Cyan"

Case "Green"
    CountObJGreen = CountObJGreen + 1
    'MyTableLinear.SetCellValue 5, 2, CountObJGreen
    'MyTableLinear.SetCellValue 5, 0, OBJECT.Layer
    ToTLengthObjGreen = ToTLengthObjGreen + OBJECT.Length
    'MyTableLinear.SetCellValue 5, 1, ToTLengthObjGreen
    LabLY_Green = "Green"

Case "Blue"
    CountObJBlue = CountObJBlue + 1
    'MyTableLinear.SetCellValue 6, 2, CountObJBlue
    'MyTableLinear.SetCellValue 6, 0, OBJECT.Layer
    ToTLengthObjBlue = ToTLengthObjBlue + OBJECT.Length
    'MyTableLinear.SetCellValue 6, 1, ToTLengthObjBlue
    LabLY_Blue = "Blue"

Case "ORANGE"
    CountObJORANGE = CountObJORANGE + 1
    'MyTableLinear.SetCellValue 7, 2, CountObJORANGE
    'MyTableLinear.SetCellValue 7, 0, OBJECT.Layer
    ToTLengthObjORANGE = ToTLengthObjORANGE + OBJECT.Length
    'MyTableLinear.SetCellValue 7, 1, ToTLengthObjORANGE
    LabLY_ORANGE = "ORANGE"
End Select

Next
ThisDrawing.Regen acAllViewports

Dim SelInsPoint As Variant
SelInsPoint = ThisDrawing.Utility.GetPoint(, "Select Insertion Point of Table: ")

Dim MyModelSpace As AcadModelSpace
Set MyModelSpace = ThisDrawing.ModelSpace

Dim MyTableLinear As AcadTable
'Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, LayCount, 2, 500, 8000)
Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, 2, 3, 500, 8000)

MyTableLinear.SetCellValue 0, 0, "LINEAR"
MyTableLinear.SetCellValue 1, 0, "LAYERS"
MyTableLinear.SetCellValue 1, 1, "LENGTH"
MyTableLinear.SetCellValue 1, 2, "OBJ COUNT"

Dim Row As Integer
Row = 2
If LabLY_Yellow = "Yellow" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_Yellow
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjYell
    MyTableLinear.SetCellValue Row, 2, CountObJYell
    Row = Row + 1
End If

If LabLY_Red = "Red" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_Red
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjRed
    MyTableLinear.SetCellValue Row, 2, CountObJRed
    Row = Row + 1
End If

If LabLY_Cyan = "Cyan" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_Cyan
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjCyan
    MyTableLinear.SetCellValue Row, 2, CountObJCyan
    Row = Row + 1
End If

If LabLY_Green = "Green" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_Green
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjGreen
    MyTableLinear.SetCellValue Row, 2, CountObJGreen
    Row = Row + 1
End If

If LabLY_Blue = "Blue" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_Blue
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjBlue
    MyTableLinear.SetCellValue Row, 2, CountObJBlue
    Row = Row + 1
End If

If LabLY_ORANGE = "ORANGE" Then
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY_ORANGE
    MyTableLinear.SetCellValue Row, 1, ToTLengthObjORANGE
    MyTableLinear.SetCellValue Row, 2, CountObJORANGE
    Row = Row + 1
End If

For X = 0 To MyTableLinear.Rows
    For Y = 0 To MyTableLinear.Columns
        MyTableLinear.SetCellAlignment X, Y, acMiddleCenter
    Next Y
Next X

End Sub

[grobnik]

Hi @Anonymous 

Optimized version:

Routine modification with adding a function in order to optimize the code for writing on table.

'Variable to be declared outside the module
Global MyTableLinear As AcadTable
Global Row As Integer

Row and MyTableLinear variables declaration commented due to declared both as Global.

Declaring a variable with "Global" means the can be used everywhere inside the project instead only inside the single routine.

'Dim Row As Integer
Row = 2
If LabLY_Yellow = "Yellow" Then
    Call AddRow(Row, "Yellow", ToTLengthObjYell, CountObJYell)
End If

If LabLY_Red = "Red" Then
    Call AddRow(Row, "Red", ToTLengthObjRed, CountObJRed)
End If

If LabLY_Cyan = "Cyan" Then
    Call AddRow(Row, "Cyan", ToTLengthObjCyan, CountObJCyan)
End If

If LabLY_Green = "Green" Then
    Call AddRow(Row, "Green", ToTLengthObjGreen, CountObJGreen)
End If

If LabLY_Blue = "Blue" Then
    Call AddRow(Row, "Blue", ToTLengthObjBlue, CountObJBlue)
End If

If LabLY_ORANGE = "ORANGE" Then
    Call AddRow(Row, "ORANGE", ToTLengthObjORANGE, CountObJORANGE)
End If

Using the function you can avoid to write the same code several time, useful if you have a lot of layers and related variable.

Function AddRow(ByVal Row As Integer, ByVal LabLY As String, ByVal ToTLength As Double, ByVal CountObj As Integer)
    MyTableLinear.InsertRows Row, 500, 1
    MyTableLinear.SetCellValue Row, 0, LabLY
    MyTableLinear.SetCellValue Row, 1, ToTLength
    MyTableLinear.SetCellValue Row, 2, CountObj
    Row = Row + 1
End Function

[Anonymous]

@grobnik big thank you sir, the file code is working, i'll try to give feedback when I use it with my many layer and lines.

Regarding on optimize codes, i'm not sure if i'm doing it right >..<

First Code: I put it under option_explicit?

Second Code: I replace this part from file code with that new codes?

'TO BE REPLACE

Dim Row As Integer
Row = 2
If LabLY_Yellow = "Yellow" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_Yellow
MyTableLinear.SetCellValue Row, 1, ToTLengthObjYell
MyTableLinear.SetCellValue Row, 2, CountObJYell
Row = Row + 1
End If

If LabLY_Red = "Red" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_Red
MyTableLinear.SetCellValue Row, 1, ToTLengthObjRed
MyTableLinear.SetCellValue Row, 2, CountObJRed
Row = Row + 1
End If

If LabLY_Cyan = "Cyan" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_Cyan
MyTableLinear.SetCellValue Row, 1, ToTLengthObjCyan
MyTableLinear.SetCellValue Row, 2, CountObJCyan
Row = Row + 1
End If

If LabLY_Green = "Green" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_Green
MyTableLinear.SetCellValue Row, 1, ToTLengthObjGreen
MyTableLinear.SetCellValue Row, 2, CountObJGreen
Row = Row + 1
End If

If LabLY_Blue = "Blue" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_Blue
MyTableLinear.SetCellValue Row, 1, ToTLengthObjBlue
MyTableLinear.SetCellValue Row, 2, CountObJBlue
Row = Row + 1
End If

If LabLY_ORANGE = "ORANGE" Then
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY_ORANGE
MyTableLinear.SetCellValue Row, 1, ToTLengthObjORANGE
MyTableLinear.SetCellValue Row, 2, CountObJORANGE
Row = Row + 1
End If

For x = 0 To MyTableLinear.Rows
For Y = 0 To MyTableLinear.Columns
MyTableLinear.SetCellAlignment x, Y, acMiddleCenter
Next Y
Next x

and the Third Code: I just put it under  the macro

Private Sub COMPUTE_Click()

....

End Sub

Function AddRow(ByVal Row As Integer, ByVal LabLY As String, ByVal ToTLength As Double, ByVal CountObj As Integer)
MyTableLinear.InsertRows Row, 500, 1
MyTableLinear.SetCellValue Row, 0, LabLY
MyTableLinear.SetCellValue Row, 1, ToTLength
MyTableLinear.SetCellValue Row, 2, CountObj
Row = Row + 1
End Function

Nothing shows up except the title of table only..

no layers, lines,cells in tables 

sorry didn't understand it well.

Again, I appreciate your help sir. 

super thank you.

[grobnik · Accepted solution]

Hi @Anonymous 

You are right, too much version, excuse me, here attached the project reviewed "optimized" with function as per last code.

I suggest to do not use Option Explicit, the option force you to declare each variable, and there is any software improvement or best performance, it's only a way to become the code more clear for an external review.

However all variables used in modified code has been declared on my side (I guess).

In any case you have to replace or better remove the section where each layer will be written on the Table, which has been substituted by Function, see the entire project difference from that on post, just for your better understand.

If you open the entire project there are also the parts of code, where it's required Table insertion point, the main columns headers  and main table title header, these part of code has been moved down after the object selected layer checks.

As per your first code there was no modification on this part (just moved little bit down, and added count column), as there was any kind of modification to selection set, everything as per your first code posted. What I have modified it's only related to table writing data and count of length and count of objects (LINE as per you selection set).

Do not copy and paste only the part that you are seeing on the post, use the entire project attached (file with dvb extension, and dwg used as test drawing with layers you indicated on your post).

The project name it's always the same, I guess you are able to open a project, goto on MANAGE Autocad Menu, Load application and open file dvb previously extracted from zip file attached and stored in a your project directory.

The code works more or less like the previous one the "core" it's the same, so starting from selection set results, check the layer for each object, made calculation of length and set a sort of "flag" indicating that there are objects on such layer, this allows you later to insert the row related to that layer with related count, and total of length.

At the beginning the table will be created just with header string, no more, then added rows.

[Anonymous]

@grobnik  thanks again sir, it's working properly, however  the adding of codes every new created layer is kinda hard, it's confusing and time consuming. I have to re-edit the codes every cad file with different layer names >..<

anyway, thank you again for this sir.

And this code that you gave me from the beginning or from my other post, I've been trying to troubleshoot it, seems the main problem is getting the:

LayersX (list of layer in selectionset with no repeated Layers)

then

LayCount will only be LayCount=LayersX .Count

I hope you could still help me figure it out, since it doesn't require me to edit the codes every adding of LAYERS

Code (I tried to revised):

Sub TOTAL_LINEAR()

Dim ASelSet As AcadSelectionSet
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant

On Error Resume Next
Set ASelSet = ThisDrawing.SelectionSets.Add("SS")
FilterType(0) = 0
FilterData(0) = "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"
FilterType(1) = 8
FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE,REINFORCEMENTS,8mm RSB by 6m,10mm RSB by 6m,12mm RSB by 6m,16mm RSB by 6m,20mm RSB by 6m,25mm RSB by 6m,28mm RSB by 6m,32mm RSB by 6m,8mm RSB by 7.5m,10mm RSB by 7.5m,12mm RSB by 7.5m,16mm RSB by 7.5m,20mm RSB by 7.5m,25mm RSB by 7.5m,28mm RSB by 7.5m,32mm RSB by 7.5m,8mm RSB by 9m,10mm RSB by 9m,12mm RSB by 9m,16mm RSB by 9m,20mm RSB by 9m,25mm RSB by 9m,28mm RSB by 9m,32mm RSB by 9m,8mm RSB by 10.5m,10mm RSB by 10.5m,12mm RSB by 10.5m,16mm RSB by 10.5m,20mm RSB by 10.5m,25mm RSB by 10.5m,28mm RSB by 10.5m,32mm RSB by 10.5m,8mm RSB by 12m,10mm RSB by 12m,12mm RSB by 12m,16mm RSB by 12m,20mm RSB by 12m,25mm RSB by 12m,28mm RSB by 12m,32mm RSB by 12m"

If Err.Number <> 0 Then
Set ASelSet = ThisDrawing.SelectionSets.Item("SS")
FilterType(0) = 0
FilterData(0) = "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"
FilterType(1) = 8
FilterData(1) = "Yellow,Red,Cyan,Green,Blue,ORANGE,REINFORCEMENTS,8mm RSB by 6m,10mm RSB by 6m,12mm RSB by 6m,16mm RSB by 6m,20mm RSB by 6m,25mm RSB by 6m,28mm RSB by 6m,32mm RSB by 6m,8mm RSB by 7.5m,10mm RSB by 7.5m,12mm RSB by 7.5m,16mm RSB by 7.5m,20mm RSB by 7.5m,25mm RSB by 7.5m,28mm RSB by 7.5m,32mm RSB by 7.5m,8mm RSB by 9m,10mm RSB by 9m,12mm RSB by 9m,16mm RSB by 9m,20mm RSB by 9m,25mm RSB by 9m,28mm RSB by 9m,32mm RSB by 9m,8mm RSB by 10.5m,10mm RSB by 10.5m,12mm RSB by 10.5m,16mm RSB by 10.5m,20mm RSB by 10.5m,25mm RSB by 10.5m,28mm RSB by 10.5m,32mm RSB by 10.5m,8mm RSB by 12m,10mm RSB by 12m,12mm RSB by 12m,16mm RSB by 12m,20mm RSB by 12m,25mm RSB by 12m,28mm RSB by 12m,32mm RSB by 12m"
End If
ASelSet.Clear
ASelSet.SelectOnScreen FilterType, FilterData

Dim LayerX As AcadLayer

Dim LayersX As AcadLayers
Set LayersX = ThisDrawing.Layers 'ASelSet.Layers

Dim LayCount As Integer
LayCount = ASelSet.count 'LayersX.count

ThisDrawing.Regen acAllViewports
On Error Resume Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Add("TABLE")

Dim SelInsPoint As Variant
SelInsPoint = ThisDrawing.Utility.GetPoint(, "Select Insertion Point of Table: ")
Dim MyModelSpace As AcadModelSpace
Set MyModelSpace = ThisDrawing.ModelSpace
Set MyTableLinear = MyModelSpace.AddTable(SelInsPoint, LayCount, 2, 500, 5000)

MyTableLinear.SetCellValue 0, 0, "Total Linear (m)"
MyTableLinear.SetCellValue 1, 0, "Description"
MyTableLinear.SetCellValue 1, 1, "Quantity"

Dim Row As Integer
Row = 2
For Each LayerX In LayersX 'ASelSet.Layers '
If LayerX.Name <> "0" And LayerX.Name <> "Defpoints" And LayerX.Name <> "AM_CL" Then
MyTableLinear.SetCellValue Row, 0, LayerX.Name
Row = Row + 1
End If
Next

Dim ObjectsName() As Variant
Dim OBJECT As AcadObject
Dim LayName() As Variant
Dim count As Integer
Dim count1 As Integer
Dim TotalLength As Long

' count = 0
' count1 = 0

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 OBJECT In ASelSet
If OBJECT.Layer = LayerX.Name Then
ReDim Preserve ObjectsName(count1)
ObjectsName(count1) = OBJECT.ObjectName

Select Case ObjectsName(count1)
Case "AcDbPolyline"
TotalLength = TotalLength + OBJECT.Length
Case "AcDbLine"
TotalLength = TotalLength + OBJECT.Length
Case "AcDbCircle"
TotalLength = TotalLength + OBJECT.Circumference
Case "AcDbArc"
TotalLength = TotalLength + OBJECT.ArcLength
End Select

End If
Next
' End If
'

For Row = 2 To LayCount
If MyTableLinear.GetCellValue(Row, 0) = LayerX.Name Then
MyTableLinear.SetCellValue Row, 1, FormatNumber(TotalLength / 1000, 2)
End If
Next Row

' LayName(count).Clear
' LayName(count) = 0
' count1 = 0
' Row = 2
TotalLength = 0
Next

End Sub

Again and again, thank you sir, I'm learning at the same time.

God Bless

[grobnik]

Hi @Anonymous

I cannot test your code if I have not the complete drawing with all listed layers and related objects.

So I cannot help you if I have not raw materials for working on it.

Send me in pvt msg the drawing, I never share it.

In anycase, seems you are counting again all drawing layers and not the layers related only to selected objcets, that from what I understand until now could be not the same, but only some of these.

You code below indicated could not works as you wish, you are collecting all layers in the drawing

Dim LayerX As AcadLayer
Dim LayersX As AcadLayers

Set LayersX = ThisDrawing.Layers 'ASelSet.Layers -> NOT TRUE this is the collection of all layers in the drawing, not only those related to selected objects.

Dim LayCount As Integer
LayCount = ASelSet.count 'LayersX.count -> NOT TRUE You can have more than one object on the same layer (Pls confirm). So this count will be not equal to total amount of layers of selected objects, this could be higher or lower.