topic Re: How to I get Layer Names (Remove/No Duplicates) in my SelectionSet of Objects in VBA Forum

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

Anonymous — Tue, 29 Sep 2020 09:24:41 GMT

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

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

grobnik — Tue, 29 Sep 2020 10:01:30 GMT

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.

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

Anonymous — Tue, 29 Sep 2020 10:12:39 GMT

@ 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

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

grobnik — Tue, 29 Sep 2020 17:49:06 GMT

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

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

Anonymous — Wed, 30 Sep 2020 04:43:57 GMT

@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.

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

grobnik — Wed, 30 Sep 2020 05:46:49 GMT

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

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

Anonymous — Wed, 30 Sep 2020 08:01:45 GMT

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

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

grobnik — Thu, 01 Oct 2020 13:22:18 GMT

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.

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

grobnik — Thu, 01 Oct 2020 15:27:20 GMT

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

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

grobnik — Thu, 01 Oct 2020 17:08:40 GMT

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

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

Anonymous — Thu, 01 Oct 2020 18:16:40 GMT

@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.

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

grobnik — Thu, 01 Oct 2020 19:01:22 GMT

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.

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

Anonymous — Fri, 02 Oct 2020 15:22:16 GMT

@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

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

grobnik — Fri, 02 Oct 2020 16:58:32 GMT

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.