Add area chart to calculated polygon

February 15, 2023

Good morning, some time ago they helped me develop a routine in which the areas of the polygons were calculated according to the data entered, for example polygons larger than 300m2, it works correctly for me, now I must add a table of areas of these lots found, identifying the apples to which they correspond as it is in the example, I hope you can help me, thank you very much.

(defun c:foo (/ a i ll n s ur)
  (cond	((and (or (setq n (getdist "\nEnter area value to check:<300> ")) (setq n 300))
	      ;; (setq c (acad_truecolordlg 1))
	      (setq s (ssget '((0 . "LWPOLYLINE") (8 . "living"))))
	      (setq i 0)
	 )
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (if (>= (setq a (vlax-curve-getarea e)) n)
	     (progn (entmake (append (entget e) '((8 . "LIVING-AREA") (62 . 1))))
		    (vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
		    (setq ll (vlax-safearray->list ll))
		    (setq ur (vlax-safearray->list ur))
		    (setq ll (mapcar '/ (mapcar '+ ll ur) '(2 2 2)))
		    (setq i (+ i a))
		    (entmake (list '(0 . "TEXT")
				   '(100 . "AcDbEntity")
				   '(67 . 0)
				   '(8 . "LIVING-AREA")
				   '(62 . 1)
				   '(100 . "AcDbText")
				   (cons 10 ll)
				   '(40 . 1.5)
				   (cons 1 (vl-princ-to-string a))
				   '(50 . 0.0)
				   '(41 . 1.0)
				   '(51 . 0.0)
				   '(71 . 0)
				   '(72 . 1)
				   (cons 11 ll)
				   '(100 . "AcDbText")
				   '(73 . 2)
			     )
		    )
	     )
	     ;; (ssdel e s)
	   )
	 )
	 ;; Print total to command line
	 (print i)
	 (print (sslength s))
	 ;;(sssetfirst nil s)
	)
  )
  (princ)
)

In this routine the calculation of areas is done to 3 decimal places, it could be changed to 2 decimal places

polygons.dwg

Edited February 15, 2023 by cyberactive

February 15, 2023

Hi

Try

Change

(cons 1 (vl-princ-to-string a))

With

(cons 1 (rtos a 2 2))

February 15, 2023

Not tested, but see if you can use it... If something's wrong, I suspect at command tokens specified for (command) inputs - here (exe (list "_.command" "token1" "token2" ...))

(defun c:parcel-areas+table ( / *error* tttt lst2table wcs initvalueslst ucsf txtsz ti ss i lw ll ur pt room col area datalst )

  (defun *error* ( m )
    (if wcs
      (if ucsf
        (while
          (not
            (and
              (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
              (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
              (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
            )
          )
          (exe (list "_.UCS" "_P"))
        )
      )
    )
    (while (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (exe (list "_.UNDO" "_E")))
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
      (setq fun nil)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;

    (defun vl-load nil
      (or cad
        (if vlax-get-acad-object
          (setq cad (vlax-get-acad-object))
          (progn
            (vl-load-com)
            (setq cad (vlax-get-acad-object))
          )
        )
      )
      (or doc (setq doc (vla-get-activedocument cad)))
      (or alo (setq alo (vla-get-activelayout doc)))
      (or spc (setq spc (vla-get-block alo)))
    )

    ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
    (or (and cad doc alo spc) (vl-load))

    (defun exe ( tokenslist )
      ( (lambda ( tokenslist / ctch )
          (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
            (progn
              (cmderr tokenslist)
              (catch_cont ctch)
            )
            (progn
              (while (< 0 (getvar (quote cmdactive)))
                (vl-cmdf "")
              )
              t
            )
          )
        )
        tokenslist
      )
    )

    (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
      (if command-s
        (if flag
          (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
            flag
            ctch
          )
          (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
            ctch
          )
        )
        (if flag
          (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
            flag
            ctch
          )
          (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
            ctch
          )
        )
      )
    )

    (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
      (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
    )

    (defun catch_cont ( ctch / gr )
      (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
      (while
        (and
          (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
          (setq gr (grread))
          (/= (car gr) 3)
          (not (equal gr (list 2 13)))
        )
      )
      (if (vl-catch-all-error-p ctch)
        ctch
      )
    )

    (defun apply_cadr->car ( sysvarvaluepair / ctch )
      (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
      (if (vl-catch-all-error-p ctch)
        (progn
          (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
          (catch_cont ctch)
        )
      )
    )

    (defun ftoa ( n / m a s b )
      (if (numberp n)
        (progn
          (setq m (fix ((if (< n 0) - +) n 1e-8)))
          (setq a (abs (- n m)))
          (setq m (itoa m))
          (setq s "")
          (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
            (setq s (strcat s (itoa b)))
            (setq a (- (* a 10.0) b))
          )
          (if (= (type n) (quote int))
            m
            (if (= s "")
              m
              (if (and (= m "0") (< n 0))
                (strcat "-" m "." s)
                (strcat m "." s)
              )
            )
          )
        )
      )
    )

    (setq sysvarpreset
      (list
        (list (quote cmdecho) 0)
        (list (quote 3dosmode) 0)
        (list (quote osmode) 0)
        (list (quote unitmode) 0)
        (list (quote cmddia) 0)
        (list (quote ucsvp) 0)
        (list (quote ucsortho) 0)
        (list (quote projmode) 0)
        (list (quote orbitautotarget) 0)
        (list (quote insunits) 0)
        (list (quote hpseparate) 0)
        (list (quote hpgaptol) 0)
        (list (quote halogap) 0)
        (list (quote edgemode) 0)
        (list (quote pickdrag) 0)
        (list (quote qtextmode) 0)
        (list (quote dragsnap) 0)
        (list (quote angdir) 0)
        (list (quote aunits) 0)
        (list (quote limcheck) 0)
        (list (quote gridmode) 0)
        (list (quote nomutt) 0)
        (list (quote apbox) 0)
        (list (quote attdia) 0)
        (list (quote blipmode) 0)
        (list (quote copymode) 0)
        (list (quote circlerad) 0.0)
        (list (quote filletrad) 0.0)
        (list (quote filedia) 1)
        (list (quote autosnap) 1)
        (list (quote objectisolationmode) 1)
        (list (quote highlight) 1)
        (list (quote lispinit) 1)
        (list (quote layerpmode) 1)
        (list (quote fillmode) 1)
        (list (quote dragmodeinterrupt) 1)
        (list (quote dispsilh) 1)
        (list (quote fielddisplay) 1)
        (list (quote deletetool) 1)
        (list (quote delobj) 1)
        (list (quote dblclkedit) 1)
        (list (quote attreq) 1)
        (list (quote explmode) 1)
        (list (quote frameselection) 1)
        (list (quote ltgapselection) 1)
        (list (quote pickfirst) 1)
        (list (quote plinegen) 1)
        (list (quote plinetype) 1)
        (list (quote peditaccept) 1)
        (list (quote solidcheck) 1)
        (list (quote visretain) 1)
        (list (quote regenmode) 1)
        (list (quote celtscale) 1.0)
        (list (quote ltscale) 1.0)
        (list (quote osnapcoord) 2)
        (list (quote grips) 2)
        (list (quote dragmode) 2)
        (list (quote lunits) 2)
        (list (quote pickstyle) 3)
        (list (quote navvcubedisplay) 3)
        (list (quote pickauto) 3)
        (list (quote draworderctl) 3)
        (list (quote expert) 5)
        (list (quote auprec) 6)
        (list (quote luprec) 6)
        (list (quote pickbox) 6)
        (list (quote aperture) 6)
        (list (quote osoptions) 7)
        (list (quote dimzin) 8)
        (list (quote pdmode) 35)
        (list (quote pdsize) -1.5)
        (list (quote celweight) -1)
        (list (quote cecolor) "BYLAYER")
        (list (quote celtype) "ByLayer")
        (list (quote clayer) "0")
      )
    )
    (setq sysvarlst (mapcar (function car) sysvarpreset))
    (setq sysvarvals (mapcar (function cadr) sysvarpreset))
    (setq sysvarvals
      (vl-remove nil
        (mapcar
          (function (lambda ( x )
            (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
          ))
          sysvarlst
        )
      )
    )
    (setq sysvarlst
      (vl-remove-if-not
        (function (lambda ( x )
          (getvar x)
        ))
        sysvarlst
      )
    )
    (setq initvalueslst
      (apply (function mapcar)
        (cons (function list)
          (list
            sysvarlst
            (mapcar (function getvar) sysvarlst)
          )
        )
      )
    )
    (apply (function mapcar)
      (cons (function setvar)
        (list
          sysvarlst
          sysvarvals
        )
      )
    )
    (while (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (exe (list "_.UNDO" "_E")))
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if (not (exe (list "_.UNDO" "_M")))
      (if doc
        (vla-startundomark doc)
      )
    )
    (if wcs
      (if (= 0 (getvar (quote worlducs)))
        (progn
          (setq ucsf
            (list
              (getvar (quote ucsxdir))
              (getvar (quote ucsydir))
              (trans (list 0.0 0.0 1.0) 1 0 t)
            )
          )
          (exe (list "_.UCS" "_W"))
        )
      )
    )
    wcs
  )

  (defun lst2table ( lst / pt pp as cols rh cw ttl data rows sty tbl r k )
    (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))
    (setq rh
      (vla-gettextheight
        (setq sty
          (vla-item
            (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle")
            (getvar 'ctablestyle)
          )
        )
        acdatarow
      )
    )
    (setq pt (vlax-3d-point (trans (setq pp (getpoint "\nPick or specify insertion of TABLE : ")) 1 0)))
    (setq as (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))))
    (setq cols (length (cadr lst)))
    (setq ttl (if (not (listp (car lst))) (car lst)))
    (setq data (if (not (listp (car lst))) (cadr lst) lst))
    (setq data (cdr lst))
    (setq rows (if (not (listp (car lst))) (1+ (length data)) (length data)))
    (if ttl
      (vla-enablemergeall sty "Title" :vlax-true)
      (vla-enablemergeall sty "Title" :vlax-false)
    )
    (setq cw (apply (function max) (mapcar (function (lambda ( x ) (apply (function max) (mapcar (function strlen) x)))) (apply (function mapcar) (cons (function list) data)))))
    (setq tbl (vla-addtable as pt rows cols (* 2.5 rh) (* 0.8 cw)))
    (if (vlax-property-available-p tbl (quote regeneratetablesuppressed) t)
      (vla-put-regeneratetablesuppressed tbl :vlax-true)
    )
    (vla-put-stylename tbl (getvar (quote ctablestyle)))
    (if ttl
      (progn
        (vla-settext tbl 0 0 ttl)
        (setq r 1)
      )
      (setq r 0)
    )
    (foreach i data
      (setq k -1)
      (foreach ii i
        (vla-settext tbl r (setq k (1+ k)) ii)
        (cond
          ( (and ttl (> r 1))
            (vla-setcellalignment tbl r k acmiddleleft)
          )
          ( (and (not ttl) (= r 0))
            nil
          )
          ( t
            (vla-setcellalignment tbl r k acmiddleleft)
          )
        )
      )
      (setq r (1+ r))
    )
    (setq cw (mapcar (function (lambda ( x ) (apply (function max) (mapcar (function strlen) x)))) (apply (function mapcar) (cons (function list) data))))
    (setq k -1)
    (foreach c cw
      (vla-setcolumnwidth tbl (setq k (1+ k)) (* c rh 1.25))
    )
    (if (vlax-property-available-p tbl (quote regeneratetablesuppressed) t)
      (vla-put-regeneratetablesuppressed tbl :vlax-false)
    )
    (vla-update tbl)
    (vl-cmdf "_.SCALE" "_L" "" "_non" pp 0.5)
  )

  (setq wcs (tttt t)) ;;; starting "library" template sub function - initialization ;;;
  (initget 6)
  (setq txtsz (cond ( (getdist (strcat "\nPick or specify text size in current DWG units <" (rtos (getvar (quote textsize)) 2 2) "> : ") ) ) ( (getvar (quote textsize)) ) ))
  (setvar (quote textsize) txtsz)
  (prompt "\nSelect boundary LWPOLYLINE(s) on Layer(s) representing names of rooms of objects drawing plan...")
  (if (setq ss (ssget (list (cons 0 "LWPOLYLINE") (cons -4 "&=") (cons 70 1))))
    (progn
      (setq ti (car (_vl-times)))
      (repeat (setq i (sslength ss))
        (setq lw (ssname ss (setq i (1- i))))
        (vla-getboundingbox (vlax-ename->vla-object lw) (quote ll) (quote ur))
        (mapcar (function set) (list (quote ll) (quote ur)) (mapcar (function safearray-value) (list ll ur)))
        (setq pt (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) ll ur))
        (setq room (cdr (assoc 8 (entget lw))))
        (setq col (cdr (assoc 62 (tblsearch "LAYER" room))))
        (setq area (vlax-curve-getarea lw))
        (setq datalst (cons (list pt room (rtos area 2 4) (itoa col)) datalst))
      )
      (foreach data datalst
        (setvar (quote cecolor) (cadddr data))
        (exe (list "_.TEXT" "_C" "_non" (car data) txtsz 0.0 (cadr data)))
        (exe (list "_.TEXT" "_C" "_non" (polar (car data) (* 1.5 pi) (* 1.25 txtsz)) txtsz 0.0 (strcat (caddr data) " sqm")))
      )
      (setvar (quote cecolor) "7")
      (apply (function lst2table)
        (list
          (append
            (list "LEGEND OF AREAS")
            (append
              (list (list "PARCEL" "AREA - sqm"))
              (mapcar (function (lambda ( x ) (list (cadr x) (strcat (caddr x) " sqm")))) datalst)
              (list (list "TOTAL" (strcat (rtos (apply (function +) (mapcar (function (lambda ( x ) (atof (caddr x)))) datalst)) 2 4) " sqm")))
            )
          )
        )
      )
      (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
      (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
    )
  )
  (*error* nil)
)

HTH.

M.R.

Edited February 16, 2023 by marko_ribar

February 15, 2023

20 minutes ago, marko_ribar said:

Not tested, but see if you can use it... If something's wrong, I suspect at command tokens specified for (command) inputs - here (exe (list "_.command" "token1" "token2" ...))

(defun c:room-areas+table ( / *error* tttt lst2table wcs initvalueslst ucsf txtsz ti ss i lw ll ur pt room col area datalst )

  (defun *error* ( m )
    (if wcs
      (if ucsf
        (while
          (not
            (and
              (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
              (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
              (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
            )
          )
          (exe (list "_.UCS" "_P"))
        )
      )
    )
    (while (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (exe (list "_.UNDO" "_E")))
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
      (setq fun nil)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;

    (defun vl-load nil
      (or cad
        (if vlax-get-acad-object
          (setq cad (vlax-get-acad-object))
          (progn
            (vl-load-com)
            (setq cad (vlax-get-acad-object))
          )
        )
      )
      (or doc (setq doc (vla-get-activedocument cad)))
      (or alo (setq alo (vla-get-activelayout doc)))
      (or spc (setq spc (vla-get-block alo)))
    )

    ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
    (or (and cad doc alo spc) (vl-load))

    (defun exe ( tokenslist )
      ( (lambda ( tokenslist / ctch )
          (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
            (progn
              (cmderr tokenslist)
              (catch_cont ctch)
            )
            (progn
              (while (< 0 (getvar (quote cmdactive)))
                (vl-cmdf "")
              )
              t
            )
          )
        )
        tokenslist
      )
    )

    (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
      (if command-s
        (if flag
          (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
            flag
            ctch
          )
          (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
            ctch
          )
        )
        (if flag
          (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
            flag
            ctch
          )
          (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
            ctch
          )
        )
      )
    )

    (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
      (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
    )

    (defun catch_cont ( ctch / gr )
      (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
      (while
        (and
          (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
          (setq gr (grread))
          (/= (car gr) 3)
          (not (equal gr (list 2 13)))
        )
      )
      (if (vl-catch-all-error-p ctch)
        ctch
      )
    )

    (defun apply_cadr->car ( sysvarvaluepair / ctch )
      (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
      (if (vl-catch-all-error-p ctch)
        (progn
          (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
          (catch_cont ctch)
        )
      )
    )

    (defun ftoa ( n / m a s b )
      (if (numberp n)
        (progn
          (setq m (fix ((if (< n 0) - +) n 1e-8)))
          (setq a (abs (- n m)))
          (setq m (itoa m))
          (setq s "")
          (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
            (setq s (strcat s (itoa b)))
            (setq a (- (* a 10.0) b))
          )
          (if (= (type n) (quote int))
            m
            (if (= s "")
              m
              (if (and (= m "0") (< n 0))
                (strcat "-" m "." s)
                (strcat m "." s)
              )
            )
          )
        )
      )
    )

    (setq sysvarpreset
      (list
        (list (quote cmdecho) 0)
        (list (quote 3dosmode) 0)
        (list (quote osmode) 0)
        (list (quote unitmode) 0)
        (list (quote cmddia) 0)
        (list (quote ucsvp) 0)
        (list (quote ucsortho) 0)
        (list (quote projmode) 0)
        (list (quote orbitautotarget) 0)
        (list (quote insunits) 0)
        (list (quote hpseparate) 0)
        (list (quote hpgaptol) 0)
        (list (quote halogap) 0)
        (list (quote edgemode) 0)
        (list (quote pickdrag) 0)
        (list (quote qtextmode) 0)
        (list (quote dragsnap) 0)
        (list (quote angdir) 0)
        (list (quote aunits) 0)
        (list (quote limcheck) 0)
        (list (quote gridmode) 0)
        (list (quote nomutt) 0)
        (list (quote apbox) 0)
        (list (quote attdia) 0)
        (list (quote blipmode) 0)
        (list (quote copymode) 0)
        (list (quote circlerad) 0.0)
        (list (quote filletrad) 0.0)
        (list (quote filedia) 1)
        (list (quote autosnap) 1)
        (list (quote objectisolationmode) 1)
        (list (quote highlight) 1)
        (list (quote lispinit) 1)
        (list (quote layerpmode) 1)
        (list (quote fillmode) 1)
        (list (quote dragmodeinterrupt) 1)
        (list (quote dispsilh) 1)
        (list (quote fielddisplay) 1)
        (list (quote deletetool) 1)
        (list (quote delobj) 1)
        (list (quote dblclkedit) 1)
        (list (quote attreq) 1)
        (list (quote explmode) 1)
        (list (quote frameselection) 1)
        (list (quote ltgapselection) 1)
        (list (quote pickfirst) 1)
        (list (quote plinegen) 1)
        (list (quote plinetype) 1)
        (list (quote peditaccept) 1)
        (list (quote solidcheck) 1)
        (list (quote visretain) 1)
        (list (quote regenmode) 1)
        (list (quote celtscale) 1.0)
        (list (quote ltscale) 1.0)
        (list (quote osnapcoord) 2)
        (list (quote grips) 2)
        (list (quote dragmode) 2)
        (list (quote lunits) 2)
        (list (quote pickstyle) 3)
        (list (quote navvcubedisplay) 3)
        (list (quote pickauto) 3)
        (list (quote draworderctl) 3)
        (list (quote expert) 5)
        (list (quote auprec) 6)
        (list (quote luprec) 6)
        (list (quote pickbox) 6)
        (list (quote aperture) 6)
        (list (quote osoptions) 7)
        (list (quote dimzin) 8)
        (list (quote pdmode) 35)
        (list (quote pdsize) -1.5)
        (list (quote celweight) -1)
        (list (quote cecolor) "BYLAYER")
        (list (quote celtype) "ByLayer")
        (list (quote clayer) "0")
      )
    )
    (setq sysvarlst (mapcar (function car) sysvarpreset))
    (setq sysvarvals (mapcar (function cadr) sysvarpreset))
    (setq sysvarvals
      (vl-remove nil
        (mapcar
          (function (lambda ( x )
            (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
          ))
          sysvarlst
        )
      )
    )
    (setq sysvarlst
      (vl-remove-if-not
        (function (lambda ( x )
          (getvar x)
        ))
        sysvarlst
      )
    )
    (setq initvalueslst
      (apply (function mapcar)
        (cons (function list)
          (list
            sysvarlst
            (mapcar (function getvar) sysvarlst)
          )
        )
      )
    )
    (apply (function mapcar)
      (cons (function setvar)
        (list
          sysvarlst
          sysvarvals
        )
      )
    )
    (while (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (exe (list "_.UNDO" "_E")))
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if (not (exe (list "_.UNDO" "_M")))
      (if doc
        (vla-startundomark doc)
      )
    )
    (if wcs
      (if (= 0 (getvar (quote worlducs)))
        (progn
          (setq ucsf
            (list
              (getvar (quote ucsxdir))
              (getvar (quote ucsydir))
              (trans (list 0.0 0.0 1.0) 1 0 t)
            )
          )
          (exe (list "_.UCS" "_W"))
        )
      )
    )
    wcs
  )

  (defun lst2table ( lst / pt as cols rh cw ttl data rows sty tbl r k )
    (setq rh
      (vla-gettextheight
        (setq sty
          (vla-item
            (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle")
            (getvar (quote ctablestyle))
          )
        )
        acdatarow
      )
    )
    (setq pt (vlax-3d-point (trans (getpoint "\nPick or specify insertion point of table : ") 1 0))
          as (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
          cols (if (listp (caadr lst)) (length (caadr lst)) (length (car lst)))
          ttl (if (not (listp (car lst))) (car lst))
          data (if (not (listp (car lst))) (cadr lst) lst)
          data (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (if (null y) "" y))) x))) data)
          rows (if (not (listp (car lst))) (1+ (length data)) (length data))
    )
    (if ttl
      (vla-enablemergeall sty "Title" :vlax-true)
      (vla-enablemergeall sty "Title" :vlax-false)
    )
    (setq cw (apply (function max) (mapcar (function (lambda ( x ) (apply (function max) (mapcar (function strlen) x)))) (apply (function mapcar) (cons (function list) data)))))
    (setq tbl (vla-addtable as pt rows cols (* 2.5 rh) (* 0.8 cw)))
    (if (vlax-property-available-p tbl (quote regeneratetablesuppressed) t)
      (vla-put-regeneratetablesuppressed tbl :vlax-true)
    )
    (vla-put-stylename tbl (getvar (quote ctablestyle)))
    (if ttl
      (progn
        (vla-settext tbl 0 0 ttl)
        (setq r 1)
      )
      (setq r 0)
    )
    (foreach i data
      (setq k -1)
      (foreach ii i
        (vla-settext tbl r (setq k (1+ k)) ii)
        (cond
          ( (and ttl (> r 1))
            (vla-setcellalignment tbl r k acmiddleleft)
          )
          ( (and (not ttl) (= r 0))
            nil
          )
          ( t
            (vla-setcellalignment tbl r k acmiddleleft)
          )
        )
      )
      (setq r (1+ r))
    )
    (setq cw (mapcar (function (lambda ( x ) (apply (function max) (mapcar (function strlen) x)))) (apply (function mapcar) (cons (function list) data))))
    (setq k -1)
    (foreach c cw
      (vla-setcolumnwidth tbl (setq k (1+ k)) (* c rh 1.25))
    )
    (if (vlax-property-available-p tbl (quote regeneratetablesuppressed) t)
      (vla-put-regeneratetablesuppressed tbl :vlax-false)
    )
    (vla-update tbl)
  )

  (setq wcs (tttt t)) ;;; starting "library" template sub function - initialization ;;;
  (if (= (setq txtsz (getvar (quote textsize))) 0.0)
    (progn
      (initget 6)
      (setq txtsz (cond ( (getdist "\nPick or specify text size in current DWG units <0.30> - 30cm : ") ) ( 0.3 )))
    )
  )
  (setvar (quote textsize) txtsz)
  (prompt "\nSelect boundary LWPOLYLINE(s) on Layer(s) representing names of rooms of objects drawing plan...")
  (if (setq ss (ssget (list (cons 0 "LWPOLYLINE") (cons -4 "&=") (cons 70 1))))
    (progn
      (setq ti (car (_vl-times)))
      (repeat (setq i (sslength ss))
        (setq lw (ssname ss (setq i (1- i))))
        (vla-getboundingbox (vlax-ename->vla-object lw) (quote ll) (quote ur))
        (mapcar (function set) (list (quote ll) (quote ur)) (mapcar (function safearray-value) (list ll ur)))
        (setq pt (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) ll ur))
        (setq room (cdr (assoc 8 (entget lw))))
        (setq col (cdr (assoc 62 (tblsearch "LAYER" room))))
        (setq area (vlax-curve-getarea lw))
        (setq datalst (cons (list pt room area col) datalst))
      )
      (foreach data datalst
        (setvar (quote cecolor) (nth 3 data))
        (exe (list "_.TEXT" "" "_non" pt room ""))
        (exe (list "_.TEXT" "" "_non" (polar pt (* 1.5 pi) 0.5) (strcat area " m²" "")))
      )
      (lst2table (list "LEGEND OF AREAS" (list (list "ROOM" "AREA") (mapcar (function (lambda ( x ) (list (cadr x) (caddr x)))) datalst))))
      (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
      (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
    )
  )
  (*error* nil)
)

HTH.

M.R.

Select boundary LWPOLYLINE(s) on Layer(s) representing names of rooms of objects drawing plan...
Select objects: Specify opposite corner: 126 found

Select objects:
Regenerating model.
Regenerating model.
Regenerating model.

Command: AutoCAD variable setting rejected: CECOLOR 157

February 15, 2023

Hi Marko the error occurs at this line

(foreach data datalst
        (setvar (quote cecolor) (nth 3 data));; error at this line 
        (exe (list "_.TEXT" "" "_non" pt room ""))
        (exe (list "_.TEXT" "" "_non" (polar pt (* 1.5 pi) 0.5) (strcat area " m²" "")))
      )

data hold

I did it at command line

Quote

Command: _SAVEAS
Command: CECOLOR
Enter new value for CECOLOR <"BYLAYER">: *Cancel*
Command: (setvar 'cecolor 7)
; error: AutoCAD variable setting rejected: CECOLOR 7
bad argument type: consp nil

But if I type as follow

Quote

Command: CECOLOR
Enter new value for CECOLOR <"BYLAYER">: 7

It work ok

table room areas.lsp room area table.dwg

February 15, 2023

: (setvar 'cecolor 45)

; ----- Error around expression -----
; 'CECOLOR
;
; error : bad argument type <45> ; expected <STRING> at [setvar]
: (setvar 'cecolor "45")

Try (setvar 'cecolor (rtos (nth 3 data) 2 0))

February 15, 2023

Also this line have to apply rtos

 (setvar (quote cecolor) (rtos (nth 3 data)2 0));; aplyed RTOS to color as NUMBER
        (exe (list "_.TEXT" "" "_non" pt room ""))
        (exe (list "_.TEXT" "" "_non" (polar pt (* 1.5 pi) 0.5) (strcat (rtos area 2 4) " m²" ""))); applied RTOS to area

February 15, 2023

please see it

(foreach data datalst
        (setvar (quote cecolor) (rtos (nth 3 data)2 0))
        (exe (list "_.TEXT" "" "_non" pt room "")); this line put the text strin "_non" att point (0 0 0 )
        ;; despite the pt variable hold (2012.55 1632.25 0.0) 
        (setq room$ (vlax-ename->vla-object(entlast)))
        (exe (list "_.TEXT" "" "_non" (polar pt (* 1.5 pi) 0.5) (strcat (rtos area 2 4) " m²" "")))
        ; this line put the text strin "_non" att point (0 0 0 )
             ;; despite the pt variable hold (2012.55 1631.75 0.0) 
        (setq area$ (vlax-ename->vla-object(entlast)))
      );ends foreach

and when ask to select the point to set the table

February 15, 2023

29 minutes ago, devitg said:

Also this line have to apply rtos

 (setvar (quote cecolor) (rtos (nth 3 data)2 0));; aplyed RTOS to color as NUMBER
        (exe (list "_.TEXT" "" "_non" pt room ""))
        (exe (list "_.TEXT" "" "_non" (polar pt (* 1.5 pi) 0.5) (strcat (rtos area 2 4) " m²" ""))); applied RTOS to area

Hi, when selecting the elements and clicking the insertion point of the box, the result is _non

February 15, 2023

Hi Cyberactive, please upload your sample DWG.

February 15, 2023

11 minutes ago, devitg said:

Hi Cyberactive, please upload your sample DWG.

Hello Devitg, if I uploaded it, it's at the beginning, but I upload it again, thank you very much for the help

polygons.dwg

February 15, 2023

This was the code that helped me at the time and it works perfectly, but now I have to generate a table of areas with the blocks to which the calculated lots that are greater than 300m2 correspond.

(defun c:foo (/ a i ll n s ur)
  (cond	((and (or (setq n (getdist "\nEnter area value to check:<300> ")) (setq n 300))
	      ;; (setq c (acad_truecolordlg 1))
	      (setq s (ssget '((0 . "LWPOLYLINE") (8 . "living"))))
	      (setq i 0)
	 )
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (if (>= (setq a (vlax-curve-getarea e)) n)
	     (progn (entmake (append (entget e) '((8 . "LIVING-AREA") (62 . 1))))
		    (vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
		    (setq ll (vlax-safearray->list ll))
		    (setq ur (vlax-safearray->list ur))
		    (setq ll (mapcar '/ (mapcar '+ ll ur) '(2 2 2)))
		    (setq i (+ i a))
		    (entmake (list '(0 . "TEXT")
				   '(100 . "AcDbEntity")
				   '(67 . 0)
				   '(8 . "LIVING-AREA")
				   '(62 . 1)
				   '(100 . "AcDbText")
				   (cons 10 ll)
				   '(40 . 1.5)
				   (cons 1 (vl-princ-to-string a))
				   '(50 . 0.0)
				   '(41 . 1.0)
				   '(51 . 0.0)
				   '(71 . 0)
				   '(72 . 1)
				   (cons 11 ll)
				   '(100 . "AcDbText")
				   '(73 . 2)
			     )
		    )
	     )
	     ;; (ssdel e s)
	   )
	 )
	 ;; Print total to command line
	 (print i)
	 (print (sslength s))
	 ;;(sssetfirst nil s)
	)
  )
  (princ)
)

February 15, 2023

I've updated post here : https://www.cadtutor.net/forum/topic/76939-add-area-chart-to-calculated-polygon/?do=findComment&comment=613733

I hope you'll find it useful...

M.R.

February 15, 2023

1 minute ago, marko_ribar said:

I've updated post here : https://www.cadtutor.net/forum/topic/76939-add-area-chart-to-calculated-polygon/?do=findComment&comment=613733

I hope you'll find it useful...

M.R.

Hello, yes I see that it is very interesting but I get this error, thank you very much for the contribution I would like it to work correctly and that is why it is my doubt to know where the error is

Select boundary LWPOLYLINE(s) on Layer(s) representing names of rooms of objects drawing plan...
Select objects: Specify opposite corner: 126 found

Select objects:
Regenerating model.
Regenerating model.
Regenerating model.

Command: AutoCAD variable setting rejected: CECOLOR 157

February 16, 2023

7 hours ago, cyberactive said:

Hello, yes I see that it is very interesting but I get this error, thank you very much for the contribution I would like it to work correctly and that is why it is my doubt to know where the error is

Select boundary LWPOLYLINE(s) on Layer(s) representing names of rooms of objects drawing plan...
Select objects: Specify opposite corner: 126 found

Select objects:
Regenerating model.
Regenerating model.
Regenerating model.

Command: AutoCAD variable setting rejected: CECOLOR 157

Test it again... I've updated it once again... Please note that you must have boundary LWPOLYLINE(S) in corresponding Layer(s) representing various room(s) specification(s) - each Layer must have different color to become distinguished with each other... Added TOTAL row to TABLE...

February 16, 2023

Just saw your DWG...

You have parcel instead of room, so I've changed my code accordingly... If you find it useful, please give it a kudo, or solution so that we know that your request founded adequate answer...

Regards, M.R.

February 16, 2023

2 hours ago, marko_ribar said:

Just saw your DWG...

You have parcel instead of room, so I've changed my code accordingly... If you find it useful, please give it a kudo, or solution so that we know that your request founded adequate answer...

Regards, M.R.

Hi Marko , first run at polygons.dwg return this error

Command line returns

Command: P-A+TBL
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Command: AutoCAD variable setting rejected: CLAYER "0"; reset after error
Command:
Command:

February 16, 2023

33 minutes ago, devitg said:

Hi Marko , first run at polygons.dwg return this error

Command line returns

Command: P-A+TBL
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Regenerating model.
Command: AutoCAD variable setting rejected: CLAYER "0"; reset after error
Command:
Command:

It doesn't occur on my PC(s)... All my CAD(s) don't error at that place - it is my template sub for writing new stuff more reliably... Why would variable CLAYER reject "0" - it must be that you removed layer "0" which is default one... Although I read that "0" Layer can't be removed, I've seen during my carrier that on one DWG it didn't exist... Please return back Layer "0" and start routine exactly from that Layer... One more thing - my code is made for many different Layer(s) colored differently for DWG's far more descriptive than OP's posted one... Still, it didn't break on my BricsCAD V23, AutoCAD 2022 and BricsCAD V21...

February 16, 2023

Hi Marko , the problem becomes because at the polygons.dwg . layer is freeze

I noticed it while testing the OP lsp

Sign In

Add area chart to calculated polygon

Recommended Posts

cyberactive

hosneyalaa

marko_ribar

cyberactive

devitg

BIGAL

devitg

devitg

cyberactive

devitg

cyberactive

cyberactive

marko_ribar

cyberactive

marko_ribar

marko_ribar

devitg

marko_ribar

devitg

Join the conversation

Tutorials

Forums

Activity