Lisp for Data extraction with blocks and polylines

[josh_buck3A23W]

I'm brand new to LISP. I'm trying to extract data to create a table on each sheet i have. It's 2D for utility contruction, so all i have are polylines, their layers, and their lengths, as well as the specific blocks and their specific layers. Can anyone help?

[pbejse]

post a sample drawing file (.dwg ) that shows what you described on your post. Also show how the table should appear on your sheet.

[CodeDing]

@josh_buck3A23W ,

Well, probably the easiest human-readable way to get information about your polylines, would be from using the (dumpallproperties ...), (getpropertyvalue ...), and (setpropertyvalue ...) methods. But they have limited properties sometimes.

(defun c:TEST ( / ClosedState LineGenState e closed lineGen)
  ;; define some helper functions
  (defun ClosedState (s) (if (zerop s) "Not Closed" "Closed"))
  (defun LineGenState (s) (if (zerop s) "Disabled" "Enabled"))
  ;; begin main work
  (setq e (car (entsel "Select Polyline: ")))
  (setq closed (getpropertyvalue e "Closed"))
  (alert (strcat "\nYour polyline is currently " (ClosedState closed) "."))
  (setq lineGen (getpropertyvalue e "Plinegen"))
  (alert (strcat "\nYour polyline line generation is currently " (LineGenState lineGen) "."))
  ;; switch it up
  (setq closed (abs (1- closed)))
  (setq lineGen (abs (1- lineGen)))
  (setpropertyvalue e "Closed" closed)
  (setpropertyvalue e "Plinegen" lineGen)
  (alert (strcat "\nYour polyline is now " (ClosedState closed) "."))
  (alert (strcat "\nYour polyline line generation is now currently " (LineGenState lineGen) "."))
  ;; finish
  (alert "Check your command history [F2] to see polyline property dump")
  (dumpallproperties e)
  (princ)
);defun

Otherwise, eventually you should also get accustomed to the DXF Format & Entity Codes to retrieve polyline data.

(defun c:TEST ( / e lyr)
  (setq e (car (entsel "Select Polyline: ")))
  (setq lyr (cdr (assoc 8 (entget e))))
  (alert (strcat "Your polyline is on layer: " lyr))
  (alert "Check your command history [F2] to see polyline Entity Code dump.")
  (print (entget e))
  (princ)
);defun

And when you're wanting to do some heavy lifting, you might eventually get into Visual Lisp (ActiveX).

(defun c:TEST ( / e coords newPoly)
  (vl-load-com)
  (setq e (vlax-ename->vla-object (car (entsel "Select Polyline: "))))
  ;; get polyline coords
  (setq coords (vlax-get e 'Coordinates))
  (alert (strcat "The coordinate list for your polyline is:\n" (vl-prin1-to-string coords)))
  ;; copy current polyline
  (setq newPoly (vlax-invoke e 'Copy))
  ;; move new polyline right & down 2 units
  (vla-Move newPoly (vlax-3d-point 0 0 0) (vlax-3d-point 2 -2 0))
  (alert "Your polyline has been copied Right 2 units & Down 2 units.")
  ;; finish up
  (alert "Check your command history [F2] to see polyline Visual Lisp property dump.")
  (vlax-dump-object e)
  (princ)
);defun

Best,

~DD

[josh_buck3A23W]

The table is in the drawing

[Sea-Haven]

Yes can be done looks relatively simple.

A comment when getting the 1-conduit etc would create the table with sorted data based on x-conduit and lengths a simple add on. Yes can see some blocks so I take it the 1st column is a count column ? Please confirm.

Re gaps in table how do we know when to leave gaps ? is 1 gap ok ?

No headings or title should there be ?

I ask these questions as some one who may provide an answer it's painful when you keep going back adding 1 extra item each time rather than do it right 1st go. Added for moment to my To do list.

[josh_buck3A23W]

Yes, the column on the left is a count column for counting the blocks. I don't care about gaps so either way would be fine. If i could add rows and columns to the table that would be nice just in case i need to do any manual entries. Title doesn't matter either. In the future I am going to be trying to figure out how to get this to create a BOM, but i know thats much more in depth

[Sea-Haven]

Create BOM ? If you mean send to Excel yes, there is table to Excel.

[Sea-Haven]

Try this

(defun c:wow ( / josh lst1 lst2 lst3 lst1a lay bname x val cnt ss len obj curspace pt1 
CreateTableStyle _sort my-count LM:ListDupes numcolumns numrows rowheight colwidth objtable)
(defun CreateTableStyle ( / dicts dictobj key class custobj )
    
;; Get the Dictionaries collection and the TableStyle dictionary
(setq dicts (vla-get-Dictionaries (vla-get-ActiveDocument(vlax-get-acad-object))))
(setq dictObj (vla-Item dicts "acad_tablestyle"))
(setq txtht 7.0)
(setq josh "No")
(vlax-for dname dictobj
(if (=  (vla-get-name dname) "Josh" ) ; does it exist
(setq josh "found")
)
)

(if (= josh "No")
(progn

;; Create a custom table style
(setq key "Josh" class "AcDbTableStyle")
(setq custObj (vla-AddObject dictObj key class))

;; Set the name and description for the style
(vla-put-Name custObj "Josh")
(vla-put-Description custObj "Josh custom table style")

;; Sets the bit flag value for the style
(vla-put-BitFlags custObj 1)

;; Sets the direction of the table, top to bottom or bottom to top
(vla-put-FlowDirection custObj acTableTopToBottom)

;; Sets the horizontal margin for the table cells
(vla-put-HorzCellMargin custObj txtht )

;; Sets the vertical margin for the table cells
(vla-put-VertCellMargin custObj txtht )

;; Set the alignment for the Data, Header, and Title rows
(vla-SetAlignment custObj (+ acDataRow acHeaderRow acTitleRow) acMiddleCenter)

;; Set the text height for the Title, Header and Data rows
(vla-SetTextHeight custObj acDataRow txtht)
(vla-SetTextHeight custObj acHeaderRow (* txtht 1.2))
(vla-SetTextHeight custObj acTitleRow (* txtht 1.5))

(setq colObj (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))

    (vla-setRGB colObj 255 0 0)
    (vla-setcolor cuStobj acTitleRow colObj)

    (vla-setRGB colObj 255 0 255)
    (vla-setcolor cuStobj acHEADERRow colObj)

;; Set the text height and style for the Title row
(vla-SetTextStyle custObj (+ acDataRow acHeaderRow acTitleRow) "Standard")

; (vla-put-regeneratetablesuppressed custobj :vlax-false)
)
)

(setvar 'ctablestyle "Josh")
  (princ)
) ; CreateTableStyle

(defun _sort (l )
(vl-sort l
	 '(lambda (a b)
	    (cond
	      ((< (car a) (car b)))
	      ((= (car a) (car b)) (< (cadr a) (cadr b)))
	    )
	  )
)
)

; By Gile
(defun my-count (a L)
  (cond
   ((null L) 0)
   ((equal a (car L)) (+ 1 (my-count a (cdr L))))
   (t (my-count a (cdr L))))
)

;; List Duplicates  -  Lee Mac
;; Returns a list of items appearing more than once in a supplied list

(defun LM:ListDupes ( l )
   (if l
       (if (member (car l) (cdr l))
           (cons (car l) (LM:ListDupes (vl-remove (car l) (cdr l))))
           (LM:ListDupes (vl-remove (car l) (cdr l)))
       )
   )
)

;;;;;;;;;;;;;;;;;;;;;; starts here  ;;;;;;;;;;;;;;;;

(setq ss (ssget '((0 . "LWPOLYLINE,INSERT"))))
(if (= ss nil)
(progn
(alert "Something went wrong no objects selected \nwill now exit")
(exit)
)
)

(setq lst1 '() lst2 '())
(repeat (setq x (sslength ss))
  (setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
  (if (= (vlax-get obj 'ObjectName) "AcDbBlockReference")
  (progn
    (setq bname (vlax-get obj 'EffectiveName )
    lay (vlax-get obj 'Layer ))
    (setq lst1 (cons (list lay bname) lst1))
  )
  (progn
    (setq lay  (vlax-get obj 'Layer ) len (vlax-get obj 'Length))
    (setq lst2 (cons (list lay len) lst2))
  )
  )
)

(setq lst1 (_sort lst1))
(setq lst2 (_sort lst2))

(setq lst3 '())
(setq lst1a (LM:ListDupes lst1))
(foreach val lst1a
 (setq cnt (my-count  val lst1))
 (setq lst3 (cons (list  (nth 0 val)(nth 1 val) (nth 2 val) cnt) lst3))
)

(CreateTableStyle)

(Setq curspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
(setq numrows 3)
(setq numcolumns 4)
(setq rowheight 25)
(setq colwidth 80)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "Heading 1")
(vla-settext objtable 1 0 "Count")
(vla-settext objtable 1 1 "Layer or\nObject")
(vla-settext objtable 1 3 "Length")
(vla-Setcolumnwidth Objtable  0 45.0)
(vla-Setcolumnwidth Objtable  1 75.0)
(vla-Setcolumnwidth Objtable  2 100.0)
(vla-Setcolumnwidth Objtable  3 55.0)
(setq objtable (vlax-ename->vla-object (entlast)))

(setq numrows 3)
(foreach val lst2
  (vla-InsertRows Objtable  numrows (vla-GetRowHeight Objtable (1- numrows)) 1)
  (vla-settext objtable numrows 1 "Polyline")
  (vla-settext objtable numrows 2 (car val))
  (vla-settext objtable numrows 3 (rtos (cadr val) 2 3))
  (setq numrows (1+ numrows))
)
(vla-InsertRows Objtable  numrows (vla-GetRowHeight Objtable (1- numrows)) 1)
(setq numrows (1+ numrows))

(foreach val lst3
  (vla-InsertRows Objtable  numrows (vla-GetRowHeight Objtable (1- numrows)) 1)
  (vla-settext objtable numrows 0 (nth 3 val))
  (vla-settext objtable numrows 1 (nth 0 val))
  (vla-settext objtable numrows 2 (nth 1 val))
  (setq numrows (1+ numrows))
)

(princ)
)
(c:wow)

[josh_buck3A23W]

Only thing that isn't pulling in my drawing are the different vaults and their layers.

A couple questions for you:

Can we change the font colors to all be black?

Is there a way to make the length a whole number instead of having decimals?

Can we automatically make the table have a white background mask?

Is there anyway that if there are multiple polylines on the same layer that the lengths combine onto one row instead of them coming in separate?

We can also delete the heading row, that won't be needed

[josh_buck3A23W]

It's working great so far though! thank you so much

[Sea-Haven]

"Can we change the font colors to all be black?"

Remove

(setq colObj (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))

    (vla-setRGB colObj 255 0 0)
    (vla-setcolor cuStobj acTitleRow colObj)

    (vla-setRGB colObj 255 0 255)
    (vla-setcolor cuStobj acHEADERRow colObj)

 "No Title"

Easiest is remove. It will still do title but will be blank.

(vla-settext objtable 0 0 "Heading 1")

 Is there a way to make the length a whole number instead of having decimals?

Change

(vla-settext objtable numrows 3 (rtos (cadr val) 2 0))

Is there anyway that if there are multiple polylines on the same layer that the lengths combine onto one row instead of them coming in separate?

I will have a think about that request, needs a rethink.

Can we automatically make the table have a white background mask?

Yes need to do as part of the make table style. 

(setq colObj (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))))
    (vla-SetRGB colObj 255 255 255)
    (vla-SetBackgroundColor Objtable (+ acHeaderRow acTitleRow acDataRow) colObj)

[josh_buck3A23W]

Thank you!!!

[Sea-Haven]

Glad to help.

[josh_buck3A23W]

Bothering you again already. Where do I go in and change the size of the table when it comes in? using the corner drag doesn't work well, so i need it to just come in smaller. Also, one of the rows just needs a formula to calculate the total lengths but i don't know how to add the code. that would maybe solve the totaling problem.

Lastly, we could get rid of one of the columns. I'd only need the count, length, and layer columns

[Sea-Haven]

I made the table match your sample, by making a table style, do you just want a smaller font ? 

The column width is controlled by the 

(vla-Setcolumnwidth Objtable  0 45.0)

Remove a column yes, the table is set early to how many columns just look for that, but if you remove a column you may have to edit the (SETTEXT row column val)  values as the column number may need changing. 

"Is there anyway that if there are multiple polylines on the same layer that the lengths combine onto one row instead of them coming in separate?" Yes needs a recode though, will have to think about it.