LISP table with hatched areas by layer name

[karpki]

Hi experts

I use a lisp to make the table of hatched areas (attached)

It makes it by the area order from biggest to smallest

How to shange lisp so  table will be made by th Layer name but not by Area ? Any ideas ?

The layer name will contain also figure f/e/ 1.aisles 2.services etc etc to build the correct order in table

[hak_vz]

(setq e (car (entsel "\nSelect table >")))
(setq eo (vlax-ename->vla-object e))
(if (vlax-property-available-p eo 'entitytransparency T) 
	(vlax-put-property eo 'entitytransparency 50)
) ;this works

(if (vlax-property-available-p eo 'CellBackgroundTransparency T)
	(vlax-put-property eo 'CellBackgroundTransparency  2 0 50)
) ;this do not work since ther is no property at least not in 2018 

So you have to check if there is a property or method to change table cell background using (vlax-dump-object eo 'T)

[GasTarRPXJ7]

Hi all,

HTL6.LSP is very useful. I have a very bad knowledge of Acad and software development. Is there any way to export the LISP table into a predefined excel sheet?

[Automohan]

Help to modify slightly to work with meter units as attached sample of cross section drawing !

[hak_vz]

@Automohan Adapted to your request

Modify table style "legend" so that text height for is set to 0.6.

(defun c:htl ( / ss layername searchlayers e i eo ss _area arealist doc pt1 area_table)
	(setq ss (ssget '((0 . "hatch"))) searchlayers '("AGGREGATE BASE COURSE" "SUBBASE" "EMBANKMENT") arealist (list))
	(foreach layername searchlayers
		(setq i -1 _area 0.0)
			(while (< (setq i (1+ i)) (sslength ss))
				(setq e (ssname ss i) eo (vlax-ename->vla-object e))
				(cond 
					((wcmatch(vla-get-layer  eo) layername)
						(setq _area (+ _area (vla-get-area  eo)))
					)
				)
			)
		(setq arealist (append arealist (list _area)))
	) 
	(setq 
		doc (vla-get-activedocument (vlax-get-acad-object))
		pt1 (vlax-3d-point (getpoint "\nPick top left table insertion point:  "))
		area_table (vla-addtable (vla-get-modelspace doc) pt1 1 2 1 1)
		area_table (vlax-ename->vla-object (entlast))
	)
	(vla-put-titlesuppressed area_table :vlax-true)
	(vla-put-headersuppressed area_table :vlax-true)
	(setq i -1)
		(while (< (setq i (1+ i)) (length arealist))
		(vla-insertrows area_table i 1.4 1)
		
		(vla-setcellvalue area_table i 0 (nth i searchlayers))
		(vla-setcellvalue area_table i 1 (rtos (nth i arealist)2 2))
		)
	(vla-setcolumnwidth area_table 0 15)
	(vla-setcolumnwidth area_table 1 5)
	(vla-deleterows area_table (1-(vla-get-rows area_table)) 1)
	(setq i -1 )
    (while (< (setq i (1+ i)) (vla-get-rows area_table))
		(vla-setrowheight area_table i 1.4)
	)
	(princ)
) 

[Jack535]

This is awesome lisp, thank you for posting it! It's exactly what I'm after as well, though for some reason it doesn't work on my smaller hatches, it doesn't give me the layer colours and it creates a huge table? Any idea which bit of the code would solve that please? 

[hak_vz]

@Jack535 I'll check it through next few days.

[cool.stuff]

Good morning,

When I try to use this lisp, I got all areas equal to zero.
Any ideas why?

Thanks

[hak_vz]

---

@cool.stuff wrote:
When I try to use this lisp, I got all areas equal to zero.
Any ideas why?

---

Because hatches should be placed in layers named

searchlayers '("AGGREGATE BASE COURSE" "SUBBASE" "EMBANKMENT")

Replace according to your need.

[cool.stuff]

Many thanks for your help.

It would be possible to change this lisp please?

Create the same table but according to color and hatch types, and compute total area according to these parameters? For selected hatches?

That would help a lot 🙂

Many many thanks  in advance 🙂

[hak_vz]

@cool.stuff 

Attach sample dwg and provide more details.

[cool.stuff]

Sample DWG.

Thanks

[hak_vz]

Try this

(defun c:htl ( / ss color searchcolors e i eo ss _area arealist doc pt1 area_table)
	(setq ss (ssget '((0 . "hatch"))) searchcolors (list) arealist (list) results (list) i -1)
	(while (< (setq i (1+ i)) (sslength ss))
	(setq color (cdr (assoc 62 (entget(ssname ss i)))))
	(if (not (member color searchcolors))(setq searchcolors (cons color searchcolors)))
	)
	(setq acc(strcat "AutoCAD.AcCmColor."  (substr (getvar 'Acadver) 1 2)))
	(foreach color searchcolors
		(setq i -1 _area 0.0)
			(while (< (setq i (1+ i)) (sslength ss))
				(setq e (ssname ss i) eo (vlax-ename->vla-object e))
				(cond 
					((equal (vla-get-color eo) color)
						(setq _area (+ _area (vla-get-area  eo)))
					)
				)
			)
		(setq arealist (append arealist (list _area)))
	) 
	(setq i -1)
	(while (< (setq i (1+ i)) (length arealist))
		(setq results (cons (list (nth i searchcolors)(nth i arealist)) results))
	)
	(setq results (vl-sort results '(lambda (x y)(> (last x)(last y)))))
	(setq searchcolors (mapcar 'car results))
	(setq arealist (mapcar 'cadr results))
	(setq 
		doc (vla-get-activedocument (vlax-get-acad-object))
		pt1 (vlax-3d-point (getpoint "\nPick top left table insertion point:  "))
		area_table (vla-addtable (vla-get-modelspace doc) pt1 1 2 1 1)
		area_table (vlax-ename->vla-object (entlast))
	)
	(vla-put-titlesuppressed area_table :vlax-true)
	(vla-put-headersuppressed area_table :vlax-true)
	(setq i -1)
		(while (< (setq i (1+ i)) (length arealist))
			(vla-insertrows area_table i 1.4 1)
			(setq clr (vlax-create-object acc))
			(vla-put-colorindex clr (nth i searchcolors))
			(vla-SetCellBackgroundColor Area_table i 0 clr)
			(vla-setcellvalue area_table i 1 (rtos (nth i arealist)2 2))
		)
	(vla-setcolumnwidth area_table 0 30)
	(vla-setcolumnwidth area_table 1 30)
	(vla-deleterows area_table (1-(vla-get-rows area_table)) 1)
	(setq i -1 )
	(while (< (setq i (1+ i)) (vla-get-rows area_table))
		(vla-setrowheight area_table i 1.4)
	)
		(princ)
) 

[cool.stuff]

Works like a charm!! 🙂

Many thanks 🙂

PS: I cannot mark as answer, just a like.. sorry...

[hak_vz]

---

@cool.stuff wrote:

Works like a charm!! 🙂🙂

PS: I cannot mark as answer, just a like.. sorry...

---

Next time start new post, paste in code you want to be altered according to your needs and mention me in that post using "@". That way you give solution author chance to receive solution point. I'm glad that code works as you expected.

[bobflopped]

thanks a lot!

[Sea-Haven]

Worked for me but I would change this line.

(setq lname(substr (setq str2 (car d)) 5 (- (strlen str2) 0)))                

(setq lname (car d))

[hak_vz]

@bobflopped 

The code you have has been written according to @karpki  request, so as @Sea-Haven  mentioned above, make changes to line related to layer name