;;---------------------=={ Area Label }==---------------------;;
;;                                                            ;;
;;  Allows the user to label picked areas or objects and      ;;
;;  either display the area in an ACAD Table (if available),  ;;
;;  optionally using fields to link area numbers and objects; ;;
;;  or write it to file.                                      ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com        ;;
;;------------------------------------------------------------;;
;;  Version 1.9    -    29-10-2011                            ;;
;;------------------------------------------------------------;;
;;  ¤¹³\¥Î¤á¼Ð°O¬B¨ú°Ï°ì©Î¹ï¶H¡AÅã¥Ü¦b ACAD ªíªº°Ï°ì¡]¦pªG¦³ªº¸Ü¡^¡A
;;  ¥ô¿ï¨Ï¥Î¦r¬qÃì±µ°Ï°ì¸¹½X©M¹ï¶H©Î¼g¤J¨ì¤å¥ó¡C

(defun c:AT nil (AreaLabel t))
;; Areas to Table
(defun c:AF nil (AreaLabel nil))
;; Areas to File

;;------------------------------------------------------------;;

(defun AreaLabel (flag	   /	    *error*  _startundo	       _endundo	_centroid	  _text	   _open    _select
		  _getobjectid	    _isannotative     acdoc    acspc	ap	 ar	  as	   cf	    cm
		  el	   fd	    fl	     fo	      n	       of	om	 p1	  pf	   pt	    sf
		  st	   t1	    t2	     tb	      th       ts	tx	 ucsxang  ucszdir
		 )

  ;;------------------------------------------------------------;;
  ;;                         Adjustments                        ;;
  ;;------------------------------------------------------------;;

  (setq	h1 "Area Table"
	;; Heading
	t1 "Number"
	;; Number Title
	t2 "Area"
	;; Area Title
	pf ""
	;; Number Prefix (optional, "" if none)
	sf ""
	;; Number Suffix (optional, "" if none)
	ap ""
	;; Area Prefix (optional, "" if none)
	as ""
	;; Area Suffix (optional, "" if none)
	cf 1.0
	;; Area Conversion Factor (e.g. 1e-6 = mm2->m2)
	fd t
	;; Use fields to link numbers/objects to table (t=yes, nil=no)
	fo "%lu6%qf1"
	   ;; Area field formatting
  )

  ;;------------------------------------------------------------;;

  (defun *error* (msg)
    (if	cm
      (setvar 'CMDECHO cm)
    )
    (if	el
      (progn (entdel el) (setq el nil))
    )
    (if	acdoc
      (_EndUndo acdoc)
    )
    (if	(and of (eq 'FILE (type of)))
      (close of)
    )
    (if	(and Shell (not (vlax-object-released-p Shell)))
      (vlax-release-object Shell)
    )
    (if	(null (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\n--> Error: " msg))
    )
    (princ)
  )

  ;;------------------------------------------------------------;;

  (defun _StartUndo (doc)
    (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  ;;------------------------------------------------------------;;

  (defun _EndUndo (doc)
    (if	(= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )

  ;;------------------------------------------------------------;;

  (defun _centroid (space objs / reg cen)
    (setq reg (car (vlax-invoke space 'addregion objs))
	  cen (vlax-get reg 'centroid)
    )
    (vla-delete reg)
    (trans cen 1 0)
  )

  ;;------------------------------------------------------------;;

  (defun _text (space point string height rotation / text)
    (setq text (vla-addtext space string (vlax-3D-point point) height))
    (vla-put-alignment text acalignmentmiddlecenter)
    (vla-put-textalignmentpoint text (vlax-3D-point point))
    (vla-put-rotation text rotation)
    text
  )

  ;;------------------------------------------------------------;;

  (defun _Open (target / Shell result)
    (if	(setq Shell (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application"))
      (progn
	(setq result
	       (and (or (eq 'INT (type target)) (setq target (findfile target)))
		    (not
		      (vl-catch-all-error-p
			(vl-catch-all-apply 'vlax-invoke (list Shell 'Open target))
		      )
		    )
	       )
	)
	(vlax-release-object Shell)
      )
    )
    result
  )

  ;;------------------------------------------------------------;;

  (defun _Select (msg pred func init / e)
    (setq pred (eval pred))
    (while
      (progn (setvar 'ERRNO 0)
	     (apply 'initget init)
	     (setq e (func msg))
	     (cond
	       ((= 7 (getvar 'ERRNO))
		(princ "\nMissed, try again.")
	       )
	       ((eq 'STR (type e))
		nil
	       )
	       ((vl-consp e)
		(if (and pred (not (pred (setq e (car e)))))
		  (princ "\nInvalid Object Selected.")
		)
	       )
	     )
      )
    )
    e
  )

  ;;------------------------------------------------------------;;

  (defun _GetObjectID (doc obj)
    (if	(vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
      (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
      (itoa (vla-get-Objectid obj))
    )
  )

  ;;------------------------------------------------------------;;

  (defun _isAnnotative (style / object annotx)
    (and
      (setq object (tblobjname "STYLE" style))
      (setq annotx (cadr (assoc -3 (entget object '("AcadAnnotative")))))
      (= 1 (cdr (assoc 1070 (reverse annotx))))
    )
  )

  ;;------------------------------------------------------------;;

  (setq	acdoc	(vla-get-activedocument (vlax-get-acad-object))
	acspc	(vlax-get-property
		  acdoc
		  (if (= 1 (getvar 'CVPORT))
		    'Paperspace
		    'Modelspace
		  )
		)

	ucszdir	(trans '(0. 0. 1.) 1 0 t)
	ucsxang	(angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 ucszdir))
  )
  (_StartUndo acdoc)
  (setq cm (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (setq	om (eq "1"
	       (cond ((getenv "LMAC_AreaLabel"))
		     ((setenv "LMAC_AreaLabel" "0"))
	       )
	   )
  )

  (setq	ts
	 (/ (getvar 'TEXTSIZE)
	    (if	(_isAnnotative (getvar 'TEXTSTYLE))
	      (cond ((getvar 'CANNOSCALEVALUE))
		    (1.0)
	      )
	      1.0
	    )
	 )
  )

  (cond
    ((not (vlax-method-applicable-p acspc 'addtable))

     (princ "\n--> Table Objects not Available in this Version.")
    )
    ((= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))

     (princ "\n--> Current Layer Locked.")
    )
    ((not
       (setq *al:num
	      (cond
		(
		 (getint
		   (strcat "\nSpecify Starting Number <"
			   (itoa (setq *al:num (1+ (cond (*al:num)
							 (0)
						   )
					       )
				 )
			   )
			   ">: "
		   )
		 )
		)
		(*al:num)
	      )
       )
     )
    )
    (flag

     (setq th
	    (* 2.
	       (if
		 (zerop
		   (setq th
			  (vla-gettextheight
			    (setq st
				   (vla-item
				     (vla-item
				       (vla-get-dictionaries acdoc)
				       "ACAD_TABLESTYLE"
				     )
				     (getvar 'CTABLESTYLE)
				   )
			    )
			    acdatarow
			  )
		   )
		 )
		  ts
		  (/ th
		     (if (_isAnnotative (vla-gettextstyle st acdatarow))
		       (cond ((getvar 'CANNOSCALEVALUE))
			     (1.0)
		       )
		       1.0
		     )
		  )
	       )
	    )
     )

     (if
       (cond
	 (
	  (progn (initget "Add")
		 (vl-consp (setq pt (getpoint "\nPick Point for Table <Add to Existing>: ")))
	  )
	  (setq	tb
		 (vla-addtable
		   acspc
		   (vlax-3D-point (trans pt 1 0))
		   2
		   2
		   th
		   (* 0.8 th (max (strlen t1) (strlen t2)))
		 )
	  )
	  (vla-put-direction tb (vlax-3D-point (getvar 'UCSXDIR)))
	  (vla-settext tb 0 0 h1)
	  (vla-settext tb 1 0 t1)
	  (vla-settext tb 1 1 t2)

	  (while
	    (progn
	      (if om
		(setq p1
		       (_Select	(strcat "\nSelect Object [Pick] <Exit>: ")
				'(lambda (x)
				   (and
				     (vlax-property-available-p (vlax-ename->vla-object x) 'area)
				     (not (eq "HATCH" (cdr (assoc 0 (entget x)))))
				     (or (eq "REGION" (cdr (assoc 0 (entget x)))) (vlax-curve-isclosed x))
				   )
				 )
				entsel
				'("Pick")
		       )
		)
		(progn (initget "Object") (setq p1 (getpoint "\nPick Area [Object] <Exit>: ")))
	      )
	      (cond
		((null p1)

		 (vla-delete tb)
		)
		((eq "Pick" p1)

		 (setq om nil)
		 t
		)
		((eq "Object" p1)

		 (setq om t)
		)
		((eq 'ENAME (type p1))

		 (setq tx
			(cons
			  (_text acspc
				 (_centroid acspc (list (setq p1 (vlax-ename->vla-object p1))))
				 (strcat pf (itoa *al:num) sf)
				 ts
				 ucsxang
			  )
			  tx
			)
		 )
		 (vla-insertrows tb (setq n 2) th 1)
		 (vla-settext
		   tb
		   n
		   1
		   (if fd
		     (strcat "%<\\AcObjProp Object(%<\\_ObjId "
			     (_GetObjectID acdoc p1)
			     ">%).Area \\f \""
			     fo
			     "\">%"
		     )
		     (strcat ap (rtos (* cf (vla-get-area p1)) 2) as)
		   )
		 )
		 (vla-settext
		   tb
		   n
		   0
		   (if fd
		     (strcat "%<\\AcObjProp Object(%<\\_ObjId "
			     (_GetObjectID acdoc (car tx))
			     ">%).TextString>%"
		     )
		     (strcat pf (itoa *al:num) sf)
		   )
		 )
		 nil
		)
		((vl-consp p1)

		 (setq el (entlast))
		 (vl-cmdf "_.-boundary" "_A" "_I" "_N" "" "_O" "_P" "" "_non" p1 "")

		 (if (not (equal el (setq el (entlast))))
		   (progn
		     (setq tx
			    (cons
			      (_text acspc
				     (_centroid acspc (list (vlax-ename->vla-object el)))
				     (strcat pf (itoa *al:num) sf)
				     ts
				     ucsxang
			      )
			      tx
			    )
		     )
		     (vla-insertrows tb (setq n 2) th 1)
		     (vla-settext tb n 1 (strcat ap (rtos (* cf (vlax-curve-getarea el)) 2) as))
		     (vla-settext
		       tb
		       n
		       0
		       (if fd
			 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
				 (_GetObjectID acdoc (car tx))
				 ">%).TextString>%"
			 )
			 (strcat pf (itoa *al:num) sf)
		       )
		     )
		     (redraw el 3)
		     nil
		   )
		   (vla-delete tb)
		 )
		)
	      )
	    )
	  )
	  (not (vlax-erased-p tb))
	 )
	 (
	  (and
	    (setq tb
		   (_Select "\nSelect Table to Add to: "
			    '(lambda (x) (eq "ACAD_TABLE" (cdr (assoc 0 (entget x)))))
			    entsel
			    nil
		   )
	    )
	    (< 1 (vla-get-columns (setq tb (vlax-ename->vla-object tb))))
	  )
	  (setq	n	(1- (vla-get-rows tb))
		*al:num	(1- *al:num)
	  )
	 )
       )
	(progn
	  (while
	    (if	om
	      (setq p1
		     (_Select (strcat "\nSelect Object ["
				      (if tx
					"Undo/"
					""
				      )
				      "Pick] <Exit>: "
			      )
			      '(lambda (x)
				 (and
				   (vlax-property-available-p (vlax-ename->vla-object x) 'area)
				   (not (eq "HATCH" (cdr (assoc 0 (entget x)))))
				   (or (eq "REGION" (cdr (assoc 0 (entget x)))) (vlax-curve-isclosed x))
				 )
			       )
			      entsel
			      (list (if	tx
				      "Undo Pick"
				      "Pick"
				    )
			      )
		     )
	      )
	      (progn (initget (if tx
				"Undo Object"
				"Object"
			      )
		     )
		     (setq p1 (getpoint	(strcat	"\nPick Area ["
						(if tx
						  "Undo/"
						  ""
						)
						"Object] <Exit>: "
					)
			      )
		     )
	      )
	    )
	     (cond
	       ((and tx (eq "Undo" p1))

		(if el
		  (progn (entdel el) (setq el nil))
		)
		(vla-deleterows tb n 1)
		(vla-delete (car tx))
		(setq n	      (1- n)
		      tx      (cdr tx)
		      *al:num (1- *al:num)
		)
	       )
	       ((eq "Undo" p1)

		(princ "\n--> Nothing to Undo.")
	       )
	       ((eq "Object" p1)

		(if el
		  (progn (entdel el) (setq el nil))
		)
		(setq om t)
	       )
	       ((eq "Pick" p1)

		(setq om nil)
	       )
	       ((and om (eq 'ENAME (type p1)))

		(setq tx
		       (cons
			 (_text	acspc
				(_centroid acspc (list (setq p1 (vlax-ename->vla-object p1))))
				(strcat pf (itoa (setq *al:num (1+ *al:num))) sf)
				ts
				ucsxang
			 )
			 tx
		       )
		)
		(vla-insertrows tb (setq n (1+ n)) th 1)
		(vla-settext
		  tb
		  n
		  1
		  (if fd
		    (strcat "%<\\AcObjProp Object(%<\\_ObjId "
			    (_GetObjectID acdoc p1)
			    ">%).Area \\f \""
			    fo
			    "\">%"
		    )
		    (strcat ap (rtos (* cf (vla-get-area p1)) 2) as)
		  )
		)
		(vla-settext
		  tb
		  n
		  0
		  (if fd
		    (strcat "%<\\AcObjProp Object(%<\\_ObjId "
			    (_GetObjectID acdoc (car tx))
			    ">%).TextString>%"
		    )
		    (strcat pf (itoa *al:num) sf)
		  )
		)
	       )
	       ((vl-consp p1)

		(if el
		  (progn (entdel el) (setq el nil))
		)
		(setq el (entlast))
		(vl-cmdf "_.-boundary" "_A" "_I" "_N" "" "_O" "_P" "" "_non" p1 "")

		(if (not (equal el (setq el (entlast))))
		  (progn
		    (setq tx
			   (cons
			     (_text acspc
				    (_centroid acspc (list (vlax-ename->vla-object el)))
				    (strcat pf (itoa (setq *al:num (1+ *al:num))) sf)
				    ts
				    ucsxang
			     )
			     tx
			   )
		    )
		    (vla-insertrows tb (setq n (1+ n)) th 1)
		    (vla-settext tb n 1 (strcat ap (rtos (* cf (vlax-curve-getarea el)) 2) as))
		    (vla-settext
		      tb
		      n
		      0
		      (if fd
			(strcat	"%<\\AcObjProp Object(%<\\_ObjId "
				(_GetObjectID acdoc (car tx))
				">%).TextString>%"
			)
			(strcat pf (itoa *al:num) sf)
		      )
		    )
		    (redraw el 3)
		  )
		  (princ "\n--> Error Retrieving Area.")
		)
	       )
	     )
	  )
	  (if el
	    (progn (entdel el) (setq el nil))
	  )
	)
     )
    )
    (
     (and
       (setq fl	(getfiled "Create Output File"
			  (cond	(*file*)
				("")
			  )
			  "txt;csv;xls"
			  1
		)
       )
       (setq of (open fl "w"))
     )
     (setq *file*  (vl-filename-directory fl)
	   de	   (cdr
		     (assoc (strcase (vl-filename-extension fl) t) '((".txt" . "\t") (".csv" . ",") (".xls" . "\t")))
		   )
	   *al:num (1- *al:num)
     )
     (write-line h1 of)
     (write-line (strcat t1 de t2) of)

     (while
       (if om
	 (setq p1
		(_Select (strcat "\nSelect Object [Pick] <Exit>: ")
			 '(lambda (x)
			    (and
			      (vlax-property-available-p (vlax-ename->vla-object x) 'area)
			      (not (eq "HATCH" (cdr (assoc 0 (entget x)))))
			      (or (eq "REGION" (cdr (assoc 0 (entget x)))) (vlax-curve-isclosed x))
			    )
			  )
			 entsel
			 '("Pick")
		)
	 )
	 (progn (initget "Object") (setq p1 (getpoint (strcat "\nPick Area [Object] <Exit>: "))))
       )
	(cond
	  ((eq "Object" p1)

	   (if el
	     (progn (entdel el) (setq el nil))
	   )
	   (setq om t)
	  )
	  ((eq "Pick" p1)

	   (setq om nil)
	  )
	  ((eq 'ENAME (type p1))

	   (_text acspc
		  (_centroid acspc (list (setq p1 (vlax-ename->vla-object p1))))
		  (strcat pf (itoa (setq *al:num (1+ *al:num))) sf)
		  ts
		  ucsxang
	   )
	   (write-line (strcat pf (itoa *al:num) sf de ap (rtos (* cf (vla-get-area p1)) 2) as) of)
	  )
	  ((vl-consp p1)

	   (if el
	     (progn (entdel el) (setq el nil))
	   )
	   (setq el (entlast))
	   (vl-cmdf "_.-boundary" "_A" "_I" "_N" "" "_O" "_P" "" "_non" p1 "")

	   (if (not (equal el (setq el (entlast))))
	     (progn
	       (_text acspc
		      (_centroid acspc (list (vlax-ename->vla-object el)))
		      (strcat pf (itoa (setq *al:num (1+ *al:num))) sf)
		      ts
		      ucsxang
	       )
	       (write-line (strcat pf (itoa *al:num) sf de ap (rtos (* cf (vlax-curve-getarea el)) 2) as) of)
	       (redraw el 3)
	     )
	     (princ "\n--> Error Retrieving Area.")
	   )
	  )
	)
     )
     (if el
       (progn (entdel el) (setq el nil))
     )
     (setq of (close of))
     (_Open (findfile fl))
    )
  )
  (setenv "LMAC_AreaLabel"
	  (if om
	    "1"
	    "0"
	  )
  )
  (setvar 'CMDECHO cm)
  (_EndUndo acdoc)
  (princ)
)

;;------------------------------------------------------------;;

(vl-load-com)
(princ)
(princ "\n:: AreaLabel.lsp | Version 1.9 | © Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Commands: \"AT\" for ACAD Table, \"AF\" for File ::")
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;