VBA code for the LIST COMMAND

[katto01]

Hello,

 

I am trying to get the properties of all objects in a drawing.

Something like using the LIST command in a loop for all objects.

Say I have 100 AcDbPolylines, and I need to extract the coordinates of the points for each of them for further calculations.

Interactively I would click on a polyline at a time, click list, and copy (by hand) the coordinates of the points.

I would like to use this process in VBA in a loop.

I did extensively searched for an answer to this question and found nothing.

Thank you

[BlackBox]

I'm not sure I understand fully what exactly you're trying to do.

 

You might consider the DATAEXTRACTION Command generally, of if you need something that specifically extracts the coordinates for each entity (following your example), that can be done quite easily; just need to understand the desired output (i.e., prompting at command line, writing to CSV, etc.).

 

More information is needed.

[Tyke]

Blackbox is correct, we need a bit more Information.

 

But if I understand you correctly in VBA you need to create a selection set of all of the polylines in the drawing and the for each polyline extract the "coordinates" property of each polyline and do something (?) with them.

 

It is a simple enough job to do but give us a bit more idea how you want to deal the coordinates of each node. In an array or a list for each polyline, in a text file or just used internally in VBA. The world is your oyster, but please crack it open, there might be a Pearl inside ;-}

 

ps BB: today is Thursday!

[katto01]

I have this code:

------------ code starts ----------------

Sub allonspecifiedlayer()

' This routine allows the user to select everything on screen. Then it goes through all

' of the objects one by one and puts them in a list along with the layer name.

' Need to create a form called objectsfrm and add a listbox called listbox1 to form.

 

'dimension these variables

Dim ssetObj As AcadSelectionSet

Dim sset As AcadSelectionSets

Dim acadobj As AcadObject

Dim objname As String

Dim objlayer As String

Dim I As Integer

I = 0

Set sset = ThisDrawing.SelectionSets

For Each ssetObj In sset

If UCase(ssetObj.Name) = "TEST" Then

sset.Item("TEST").Delete

Exit For

End If

Next

Set ssetObj = ThisDrawing.SelectionSets.Add("TEST")

' Add all the objects to the selection set

ssetObj.Select acSelectionSetAll

For Each acadobj In ssetObj

'Filter out everything on specified layer.

If acadobj.Layer = "objects" Then

objname = acadobj.ObjectName

objlayer = acadobj.Layer

Debug.Print objname, acadobj.Handle 'objectsfrm.ListBox1.AddItem objname

I = I + 1

End If

Next acadobj

'Show form

'objectsfrm.show

End Sub

------------ code ends -------------

 

for each objname in the loop I wopuld like to extract all the info (especially coordinates ) and writing on an excel sheet

[Tyke]

You need to read up on posting code. You will get a mod in your neck for what you just posted!

[Tyke]

Instead of filtering all objects in the drawing you should just filter the polylines on that layer. At the moment I cannot be much more help as I am not on a machine with AutoCAD.

 

What you want is doable. Code the following:

 

filter all the polylines on the layer (? or all polylines in the drawing?)

make your Connection to Excel

for each polyline in your selection set create a loop where you write the coordinates of each node to Excel, incrementing Excel cell values for each Point

enter a blank line in Excel (?) to show a new polyline is about to start

when you are done close the connection to Excel

[SLW210]

You need to read up on posting code. You will get a mod in your neck for what you just posted!

 

Please read the Code posting guidelines and edit your post to include the Code in Code Tags.

[BlackBox]

Blackbox is correct, we need a bit more Information.

 

*Tips hat*

 

ps BB: today is Thursday!

 

... But yesterday wasn't.

 

 

 

for each objname in the loop I wopuld like to extract all the info (especially coordinates ) and writing on an excel sheet

 

Unfortunately, you're still not providing enough information... We get that you want to export the data to Excel... As a CSV dump of all coordinates? One CSV for each polyline? We need some sort of example of the desired output in order to even begin giving you pointers in the right direction so that you can code what you're after.

 

Cheers

[katto01]

I apologize. let me try this:

 

1. I have a drawing with many different objects (polylines, lightpolylines, cubes, spheres, etc.)

2. I need to get the equivalent of the information provided by the command LIST.

3. Organize the information in a table in an excel file (not csv) in a similar way the LIST command displays it

 

LWPOLYLINE Layer "0"

Handle 1bd

Closed

Constant width 0.0000

area 6.8234

perimeter 10.4581

at point X= 12.0160 Y= 11.8917 Z= 0.0000

at point X= 14.7416 Y= 11.8917 Z= 0.0000

at point X= 14.7416 Y= 9.3883 Z= 0.0000

at point X= 12.0160 Y= 9.3883 Z= 0.0000

[BIGAL]

This is VL code but is easily converted to VBA it uses the properties function to get the co-ords same as you can get "layer" "Color" "width etc hope it is helpfull

 

(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)

(defun co-ords2xy (I numb xy)
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq numb (/ (length co-ords) 2))
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)

; program starts here
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy)

(princ co-ordsxy)

[Tyke]

Or if you want it in VBA:

 

Sub ListProps()
   
   Dim ssPolys     As AcadSelectionSet
   Dim ssName      As String
   Dim intCodes()  As Integer
   Dim varValues   As Variant
   Dim objEnt      As AcadEntity
   Dim objLWPoly   As AcadLWPolyline
   Dim objPoly     As AcadPolyline
   
   Dim strName     As String
   Dim strLayer    As String
   Dim strHandle   As String
   Dim strClosed   As String
   Dim dblWidth    As Double
   Dim dblArea     As Double
   Dim dblPerim    As Double
   Dim dblCoords() As Double
   
   On Error Resume Next
   
   ssName = "ssPolys"
   
   ' try to set the selection set
   Set ssPolys = ThisDrawing.SelectionSets(ssName)
   
   ' if it does not exist an error will occur - so add it
   If Err Then
       Set ssPolys = ThisDrawing.SelectionSets.Add(ssName)
   End If
   
   ' clear all data from selection set
   ssPolys.Clear
   
   ' set the filter
   ReDim intCodes(5): ReDim varValues(5)
   
   intCodes(0) = -4: varValues(0) = "<and"
   intCodes(1) = -4: varValues(1) = "<or"
   intCodes(2) = 0:  varValues(2) = "PolyLine"
   intCodes(3) = 0:  varValues(3) = "LwPolyLine"
   intCodes(4) = -4: varValues(4) = "or>"
   intCodes(5) = -4: varValues(5) = "and>"
   
   ssPolys.Select acSelectionSetAll, , , intCodes, varValues
   
   ' now make your connection to Excel
   
   ' now you have all the polylines in a selection set iterate it to get the properties
   For Each objEnt In ssPolys
       strClosed = "Open"
       If objEnt.ObjectName = "AcDbPolyline" Then
           strName = "Polyline2D"    'objLWPoly.ObjectName
       Else
           strName = "LWPolyline"     'objPoly.ObjectName
       End If
       
       ' extract the properties
       strName = objEnt.ObjectName
       strLayer = objEnt.Layer
       strHandle = objEnt.Handle
       If objEnt.Closed = True Then strClosed = "Closed"
       dblWidth = objEnt.ConstantWidth
       dblArea = objEnt.Area
       dblPerim = objEnt.Length
       dblCoords = objEnt.Coordinates
       
       ' send the above properties to Excel
       
       ' iterate through the coords array and send the coordinates to Excel
       
   Next objEnt
   
   ' close your connection to Excel
   
End Sub

[katto01]

Perfect, this is what I was looking for.

[SLW210]

Please read the Code posting guidelines and edit your post to include the Code in Code Tags.

 

Did you overlook this?