VBA: list of lines

[puffeltje]

Is it possible within VBA to create a list of all the lines (with their starting- and ending-coordinates) in a drawing?

VBA (or VB) is not new to me, but the combination with Autocad is.

[rkmcswain]

Is it possible within VBA to create a list of all the lines (with their starting- and ending-coordinates) in a drawing?

Yes.

 

Create a filtered selection set for LINE entities, then iterate this selection set, querying the desired properties. The help file contains an example of filtering a selection set, and there is a good tutorial here: http://usa.autodesk.com/adsk/servlet/item?siteID=123112&id=2768231&linkID=9240615

[fixo]

Is it possible within VBA to create a list of all the lines (with their starting- and ending-coordinates) in a drawing?

VBA (or VB) is not new to me, but the combination with Autocad is.

 

Welcome on board!

Try this example

 

Option Explicit

Sub AllLinesData()
   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim fcode(0) As Integer
   Dim fData(0) As Variant
   Dim dxfcode, dxfdata
   Dim setName As String
   Dim i As Integer
   Dim n As Integer
   Dim s As String

   fcode(0) = 0
   fData(0) = "LINE"

   dxfcode = fcode
   dxfdata = fData
   setName = "$Lines$"

   '// make sure the selection set does not exist
   For i = 0 To ThisDrawing.SelectionSets.Count - 1
       If ThisDrawing.SelectionSets.Item(i).Name = setName Then
           '// if this named selection set is already exist then delete it
           ThisDrawing.SelectionSets.Item(i).Delete
           Exit For
       End If
   Next i
   '// add new selection set with this name
   Set oSset = ThisDrawing.SelectionSets.Add(setName)
   oSset.Select acSelectionSetAll, , , dxfcode, dxfdata

   On Error GoTo Err_Control

   '// loop through all lines
   ReDim lineArr(0 To oSset.Count - 1, 0 To 6) As Variant
   For n = 0 To oSset.Count - 1
       Dim cEnt As AcadEntity
       Set cEnt = oSset.Item(n)
       Dim oLine As AcadLine
       Set oLine = cEnt
       Dim startp As Variant
       '// get the start point
       startp = oLine.StartPoint
       Dim endp As Variant
       '// get the end point
       endp = oLine.EndPoint
       '// collect line handles and points into a two-dimensional array
       lineArr(n, 0) = oLine.Handle
       lineArr(n, 1) = startp(0)
       lineArr(n, 2) = startp(1)
       lineArr(n, 3) = startp(2)
       lineArr(n, 4) = endp(0)
       lineArr(n, 5) = endp(1)
       lineArr(n, 6) = endp(2)
   Next n
   '// clean up memory
   oSset.Delete
   '// do what you want with array 'lineArr' here, e.g. write data to the text file etc.

   Open "C:\AllLines.txt" For Output As #1    'Open file for output
   For n = 0 To UBound(lineArr, 1)
       s = ""
       For i = 0 To UBound(lineArr, 2)
           s = s & CStr(lineArr(n, i)) & ","
       Next i
       Write #1, Left(s, Len(s) - 1)    'Write comma-delimited data (cut the last comma from string)
   Next n
   Close #1    'Close file

Err_Control:
   MsgBox Err.Description

End Sub

 

~'J'~

[puffeltje]

Thanks, tried the code and it does what i need. With this code i can complete my program a little bit more.

[fixo]

You're welcome

Glad to help

 

~'J'~

[puffeltje]

I addapted the code to get the start- and enppoints for LWPolylines. This works for lwpolylines with 1 vertex. When i draw a lwpolyline with multiple vertices i see that the groupcode "90" represents the number of vertices. How can i read the context of groupcode "90", or is there an otherway to determine the number of vertices?

[fixo]

Try insread this slightly edited version

 

Option Explicit

Sub AllPlinesData()
   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim fcode(0) As Integer
   Dim fData(0) As Variant
   Dim dxfcode, dxfdata
   Dim setName As String
   Dim i As Integer
   Dim n As Integer
   Dim s As String

   fcode(0) = 0
   fData(0) = "LWPOLYLINE"

   dxfcode = fcode
   dxfdata = fData
   setName = "$Plines$"

   '// make sure the selection set does not exist
   For i = 0 To ThisDrawing.SelectionSets.Count - 1
       If ThisDrawing.SelectionSets.Item(i).Name = setName Then
           '// if this named selection set is already exist then delete it
           ThisDrawing.SelectionSets.Item(i).Delete
           Exit For
       End If
   Next i
   '// add new selection set with this name
   Set oSset = ThisDrawing.SelectionSets.Add(setName)
   oSset.Select acSelectionSetAll, , , dxfcode, dxfdata

   On Error GoTo Err_Control

   '// loop through the all light polylines
   ReDim plineAr(0 To oSset.Count - 1, 0 To 4) As Variant
   For n = 0 To oSset.Count - 1
       Dim cEnt As AcadEntity
       Set cEnt = oSset.Item(n)
       Dim oPline As AcadLWPolyline
       Set oPline = cEnt
       Dim coord As Variant
       '// get coordinates
       coord = oPline.Coordinates
       '// collect polyline handles and points into a two-dimensional array
       plineAr(n, 0) = oPline.Handle
       plineAr(n, 1) = coord(0) ' <--X start point
       plineAr(n, 2) = coord(1) ' <--Y start point
       plineAr(n, 3) = coord(UBound(coord) - 1) ' <--X end point
       plineAr(n, 4) = coord(UBound(coord)) ' <--Y end point

   Next n
   '// clean up memory
   oSset.Delete
   '// do what you want with array 'plineAr' here, e.g. write data to the text file etc.

   Open "C:\AllPlines.txt" For Output As #1    'Open file for output
   For n = 0 To UBound(plineAr, 1)
       s = ""
       For i = 0 To UBound(plineAr, 2)
           s = s & CStr(plineAr(n, i)) & ","
       Next i
       Write #1, Left(s, Len(s) - 1)    'Write comma-delimited data (cut the last comma from string)
   Next n
   Close #1    'Close file

Err_Control:
   MsgBox Err.Description

End Sub

 

~'J'~

[puffeltje]

The code only returns the beginning and endig of the polyline. i changed a part of the code to this:

 

 
'// get coordinates
coord = oPline.Coordinates
'// collect polyline handles and points into a two-dimensional array
xtemp = coord(0) ' <--X start point
ytemp = coord(1) ' <--Y start point
For j = 0 To (UBound(coord) - 1) / 2 - 1


[indent]ReDim Preserve plinear(3, PLindex) As Variant ' <--create vertex in array
plinear(0, PLindex) = xtemp ' <--X start point
plinear(1, PLindex) = ytemp ' <--Y start point
plinear(2, PLindex) = coord(j * 2 + 2) ' <--X end point
plinear(3, PLindex) = coord(j * 2 + 3) ' <--Y end point
xtemp = plinear(2, PLindex) ' <--save X end point as new X start point
ytemp = plinear(3, PLindex) ' <--save Y end point as new Y start point
PLindex = PLindex + 1 ' <--increment number of vertex
[/indent]
Next j

 

Now all the start points and end points of the vertices are returned. Thanks all for the help

[FELIX]

puffeltje,

 

I tried incorporating your code to sample code that Fixo provided and was unable to get it to execute. Can you help. Would like to try your code.

Thanks.

[puffeltje]

Oeps, i didn't post all my changes:oops: . Here is the working code:

 

 
Option Explicit
Sub AllPlinesData()
   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim fcode(0) As Integer
   Dim fData(0) As Variant
   Dim dxfcode, dxfdata
   Dim setName As String
   Dim i As Integer
   Dim n As Integer
   Dim s As String
   Dim xtemp
   Dim ytemp
   Dim j
   Dim PLindex

   fcode(0) = 0
   fData(0) = "LWPOLYLINE"
   dxfcode = fcode
   dxfdata = fData
   setName = "$Plines$"
   '// make sure the selection set does not exist
   For i = 0 To ThisDrawing.SelectionSets.Count - 1
       If ThisDrawing.SelectionSets.Item(i).Name = setName Then
           '// if this named selection set is already exist then delete it
           ThisDrawing.SelectionSets.Item(i).Delete
           Exit For
       End If
   Next i
   '// add new selection set with this name
   Set oSset = ThisDrawing.SelectionSets.Add(setName)
   oSset.Select acSelectionSetAll, , , dxfcode, dxfdata
   On Error GoTo Err_Control
   '// loop through the all light polylines
   ReDim plinear(0 To 3, 0 To oSset.Count - 1) As Variant
   PLindex = 0
   For n = 0 To oSset.Count - 1
       Dim cEnt As AcadEntity
       Set cEnt = oSset.Item(n)
       Dim oPline As AcadLWPolyline
       Set oPline = cEnt
       Dim coord As Variant
       '// get coordinates
       coord = oPline.Coordinates
       '// collect polyline handles and points into a two-dimensional array
       xtemp = coord(0) ' <--X start point
       ytemp = coord(1) ' <--Y start point
       For j = 0 To (UBound(coord) - 1) / 2 - 1
           ReDim Preserve plinear(3, PLindex) As Variant ' <--create vertex in array
           plinear(0, PLindex) = xtemp ' <--X start point
           plinear(1, PLindex) = ytemp ' <--Y start point
           plinear(2, PLindex) = coord(j * 2 + 2) ' <--X end point
           plinear(3, PLindex) = coord(j * 2 + 3) ' <--Y end point
           xtemp = plinear(2, PLindex) ' <--save X end point as new X start point
           ytemp = plinear(3, PLindex) ' <--save Y end point as new Y start point
           PLindex = PLindex + 1 ' <--increment number of vertex
       Next j
   Next n
   '// clean up memory
   oSset.Delete
   '// do what you want with array 'plineAr' here, e.g. write data to the text file etc.
   Open "C:\AllPlines.txt" For Output As #1    'Open file for output
   For n = 0 To UBound(plinear, 2)
       Write #1, plinear(0, n); plinear(1, n); plinear(2, n); plinear(3, n)
   Next n
   Close #1    'Close file
Err_Control:
   MsgBox Err.Description
End Sub

 

In the file you get all the segments of the polylines. I only tried it with segments with the same startingwidth and endingwidth (and no curves). I think it can work for all sort of polylines, but i am not shure.

[FELIX]

Thanks for the update, puffeltje. I ran the code and looks like it worked. I will add the object entity handle number in the code again since your code doesn't have that. Beside that I did not get any errors. Thanks again.

[FELIX]

puffeltje,

Do you think you can help me by adding the object entity handle number or ID, the segment number, and the segment length to your code?

 

Something like this:

1A, Segment 1, x coord, y coord, x2 coord, y2coord, length

1A, segment 2, x coord, y coord, x2 coord, y2coord, length