Create the outline automatically by lisp

[cwtwong]

Hi, I want to create the outline automatically by lisp if the text value are same (see capture screen). Is it possible?

Thanks.

[braudpat]

Hello @hak_vz 

I always like your beautiful solution ! ... Please may I ask for a small improvment !?

First ask to select multiples TEXTs (which can be numbers / letters - Codes in fact for each polygone),

sort them , eliminate multiple double codes ...) and construct the list "categories" ... And then your OBT routine ...

And (if possible ?!) display at the end:

XX Polygons with Code: A 

YY Polygons with Code: B

Etc

Total of NNN Polygons

Thanks in advance for your attention !

THE HEALTH (Stay Safe), Regards, Patrice

[hak_vz · Accepted solution]

@braudpat 

Here is version updated according to your request! 

(defun c:OBTBP ( / cat ss ssd i j lines coords pt p1 p2 hits categories getregionlines show_result pointlist2d LM:Unique tot *error*)
(defun *error* ()
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ)
)
(defun getregionlines (region / ret)
	(setq ret (mapcar 'vlax-vla-object->ename (vlax-safearray->list(vlax-variant-value(vla-explode (vlax-ename->vla-object region))))))
	(entdel region)
	ret
)
(defun show_result (hits categories tot / ret sorted )
	(setq ret "")
	(foreach hit hits
		(setq sorted (cons  (list hit (itoa hit) " polygons with Code: " (car categories) " \n") sorted))
		(setq categories (cdr categories))
	)
	(setq sorted (mapcar 'cdr (vl-sort sorted '(lambda (x y) (> (car x) (car y))))))
	(foreach string sorted
		(setq ret (strcat ret (apply 'strcat string)))
	)
	(setq ret (strcat ret "\nTotal number of polygons: " (itoa tot) "\n"))
	(alert ret)
	(princ ret)
	(princ)
)

(defun pointlist2d (lst / ret)(while lst (setq ret (cons (list (car lst)(cadr lst)) ret) lst (cddr lst))) (reverse ret))

;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique ( l )(if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))))

(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(setq p1 (getpoint "\nSelect lower left corner of selection box >"))
	(setq p2 (getcorner p1 "\nSelect upper rigth corner of selection box >"))
	(setq ss (ssget "_W" p1 p2 '((0 . "*text"))) i 0 tot 0)
	(while (< i (sslength ss))(setq categories (cons (cdr (assoc 1 (entget(ssname ss i)))) categories) i (+ i 1)))
	(setq categories (lm:Unique categories))
	
	(setvar 'cmdecho 0)
	(foreach cat categories
		(setq ss (ssget "X" (list (cons 0 "*TEXT") (cons 1 cat))))
		(if (and ss)
			(progn
				(setq ssd (ssadd) i 0)
				(while 
					(< i (sslength ss))
						(setq pt (cdr (assoc 10 (entget(ssname ss i)))))
						(command "-boundary" pt "")
						(command "region" (entlast) "")
						(ssadd (entlast) ssd)
					(setq i (+ i 1))
				)
				(command "union" ssd "")
				(command "explode" (entlast))
				(setq ss (ssget "X" '((0 . "REGION"))) i 0)
				(while (and ss (< i (sslength ss)))
					(setq lines (getregionlines (ssname ss i)))
						(setq ssd (ssadd))
						(foreach line lines (setq ssd (ssadd line ssd)))
						(command "_.pedit" "_multiple" ssd "" "" "_join" "" "")
						(setq coords (pointlist2d (vlax-get (vlax-ename->vla-object (entlast)) 'coordinates)))
						(setq coords (append coords (list(car coords))))
						(setq ssd (ssget "_CP" coords '((0 . "*TEXT"))))
						(if (and ssd (> (sslength ssd) 1)) 
							(progn
								(setq j (- (sslength ssd) 1))
								(while (> j 0)
									(entdel (ssname ssd j))
								 (setq j (- j 1))
								)
							)
						)
				(setq i (+ i 1))			
				)
				(setq hits (cons (sslength ss) hits) tot (+ tot (sslength ss)))			
			)
		)
	)
(setq hits (reverse hits))
(show_result hits categories tot)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ "\nDone!")
(princ) 
)

[braudpat]

Hello @hak_vz 

1) THANKS - Always nice / beautiful routine !

2) Maybe you have forgotten to sort the "categories" list !? 

Because Total per Categories is not sorted ! 

3) And if I can ask for an other small improvment : 

- Display Total (Number of polygons) per Category AND the Total Area (with current Units) 

- AND IDEM for the grand general Total ... Please display the grand general Total Area 

Of course, if it is not a lot of Work !?

THANKS Again for your effort and attention !

THE HEALTH (Stay Safe / Stay Home / Stay Live), Regards, Patrice

[hak_vz · Accepted solution]

@braudpat 

Here is updated code. I hope this is what you are looking for. It my need some more thorough testing in various situation, and some security checks, but in general it should work ok.

Code created here has give me an idea how to solve some of my older codes that performed badly in some situations, so all this effort wasn't wasted.

(defun c:OBTBP ( / cat ss ssd i j lines coords pt p1 p2 hits categories getregionlines show_result pointlist2d LM:Unique tot arr areas total_area_sum *error*)
(defun *error* ()
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ)
)
(defun getregionlines (region / ret)
	(setq ret (mapcar 'vlax-vla-object->ename (vlax-safearray->list(vlax-variant-value(vla-explode (vlax-ename->vla-object region))))))
	(entdel region)
	ret
)
(defun show_result (hits categories tot_polygons areas total_area_sum / ret sorted )
	(setq ret "")
	(foreach hit hits
		(setq sorted (cons  (list (car areas) (itoa hit) " polygons with Code: " (car categories) " - A = " (rtos(car areas)2 2) " sq. units \n") sorted))
		(setq categories (cdr categories) areas (cdr areas))
	)
	(setq sorted (mapcar 'cdr (vl-sort sorted '(lambda (x y) (> (car x) (car y))))))
	(foreach string sorted
		(setq ret (strcat ret (apply 'strcat string)))
	)
	(setq ret (strcat ret "\nTotal number of polygons: " (itoa tot_polygons) "\n"))
	(setq ret (strcat ret "\nTotal area of all polygons: " (rtos total_area_sum 2 2) "\n"))
	(alert ret)
	(princ)
	(princ ret)
	(princ)
)

(defun pointlist2d (lst / ret)(while lst (setq ret (cons (list (car lst)(cadr lst)) ret) lst (cddr lst))) (reverse ret))

;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique ( l )(if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))))

(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(setq p1 (getpoint "\nSelect lower left corner of selection box >"))
	(setq p2 (getcorner p1 "\nSelect upper rigth corner of selection box >"))
	(setq ss (ssget "_W" p1 p2 '((0 . "*text"))) i 0 tot_polygons 0 total_area_sum 0)
	(while (< i (sslength ss))(setq categories (cons (cdr (assoc 1 (entget(ssname ss i)))) categories) i (+ i 1)))
	(setq categories (lm:Unique categories))
	
	(setvar 'cmdecho 0)
	(foreach cat categories
		(setq ss (ssget "X" (list (cons 0 "*TEXT") (cons 1 cat))))
		(if (and ss)
			(progn
				(setq ssd (ssadd) i 0)
				(while 
					(< i (sslength ss))
						(setq pt (cdr (assoc 10 (entget(ssname ss i)))))
						(command "-boundary" pt "")
						(command "region" (entlast) "")
						(ssadd (entlast) ssd)
					(setq i (+ i 1))
				)
				(command "union" ssd "")
				(command "explode" (entlast))
				(setq ss (ssget "X" '((0 . "REGION"))) i 0 arr 0)
				(while (and ss (< i (sslength ss)))
						(setq arr (+ arr (vlax-get (vlax-ename->vla-object (ssname ss i)) 'area)))
					    (setq lines (getregionlines (ssname ss i)))
						(setq ssd (ssadd))
						(foreach line lines (setq ssd (ssadd line ssd)))
						(command "_.pedit" "_multiple" ssd "" "" "_join" "" "")
						
						(setq coords (pointlist2d (vlax-get (vlax-ename->vla-object (entlast)) 'coordinates)))
						(setq coords (append coords (list(car coords))))
						(setq ssd (ssget "_CP" coords '((0 . "*TEXT"))))
						(if (and ssd (> (sslength ssd) 1)) 
							(progn
								(setq j (- (sslength ssd) 1))
								(while (> j 0)
									(entdel (ssname ssd j))
								 (setq j (- j 1))
								)
							)
						)
				(setq i (+ i 1))			
				)
				(setq hits (cons (sslength ss) hits) areas (cons arr areas) total_area_sum (+ total_area_sum arr) tot_polygons (+ tot_polygons (sslength ss)))			
			)
		)
	)
(setq hits (reverse hits) areas (reverse areas))
(show_result hits categories tot_polygons areas total_area_sum)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ "\nDone!")
(princ) 
)

[cwtwong]

Hi hak_vz, 

That's brilliant! Thank you very much!!!!

[braudpat]

Hello @hak_vz 

As already said : That's brilliant ! Thank you very much !!

For my French ACAD MAP , I add a few "underscore" to run on any language ...

THE HEALTH (Stay Safe, Stay Home, Stay Live), Regards, Patrice (The Old French EE Froggy)

PS1 : I will retire the 30 September 2020 after 36 years of ACAD (beginning end of 1984 with ACAD R1.4), 26 years of ACAD MAP, 4 years of REVIT / InfraWorks, etc ...

PS2: But I will remain active ! So you will have to support me !?

[braudpat]

Hello @hak_vz 

As already said : That's brilliant ! Thank you very much !!

For my French ACAD MAP , I add a few "underscore" to run on any language ...

THE HEALTH (Stay Safe, Stay Home, Stay Live), Regards, Patrice (The Old French EE Froggy)

PS1 : I will retire the 30 September 2020 after 36 years of ACAD (beginning end of 1984 with ACAD R1.4), 26 years of ACAD MAP, 4 years of REVIT / InfraWorks, etc ...

PS2: But I will remain active ! So you will have to support me !?