;;; ============================================================================ ;;; AREA_TO.lsp -- Survey Area Calculation by Quadrilateral Decomposition ;;; ============================================================================ ;; --- Layer name used for all entities created by this tool -------------- (setq *AT-LAYER* "gunakar book maap") ;; --- Styling Codes --------------------------------- (setq *AT-COL-CLEAN* 5) ; Blue (setq *AT-LT-CLEAN* "Continuous") ; Continuous line for main cleaned poly (setq *AT-COL-QUAD* 5) ; Blue (setq *AT-LT-QUAD* "DASHED") ; Dashed line for all quad geometry (setq *AT-COL-CORNER* 5) ; arc-closure corner polylines color (setq *AT-LT-CORNER* "DASHED2") (setq *AT-COL-QUADNUM* 2) ; Color for the Quad Number Text (2 = Yellow) ;; --- Text heights (drawing units) -------------------------------------- (setq *AT-TXT-QUADNUM* 1.97) (setq *AT-TXT-TABLE-VAL* 1.18) (setq *AT-TXT-TABLE-HDR* 1.47) (setq *AT-TXT-TABLE-TITLE* 2.00) (setq *AT-TXT-COMPARE* 1.18) ;; --- Table geometry ---------------------------------------------------- (setq *AT-TABLE-WIDTH* 150.0) (setq *AT-TABLE-ROW-H* 6.0) (setq *AT-TABLE-FONT* "Arial") ;; --- Hatch settings for corners ---------------------------------------- (setq *AT-HATCH-PATTERN* "SOLID") (setq *AT-HATCH-SCALE* 1.0) (setq *AT-HATCH-COLOR* 5) ;; --- Numerical settings ------------------------------------------------ (setq *AT-DECIMALS* 2) (setq *AT-TOL-VERTEX* 0.01) (setq *AT-TOL-AREA-PCT* 1.0) ;; Global tracking lists (setq *AT-GLOBAL-MARKS* '()) (setq *AT-HATCH-LIST* '()) ;;; ========================================================================= ;;; GENERIC HELPERS ;;; ========================================================================= (defun at:fmt (n / ) (rtos (float n) 2 *AT-DECIMALS*)) (defun at:dist2d (p1 p2) (sqrt (+ (expt (- (car p2) (car p1)) 2.0) (expt (- (cadr p2) (cadr p1)) 2.0))) ) (defun at:flat (p) (list (car p) (cadr p) 0.0)) (defun at:peq (p1 p2 tol) (<= (at:dist2d p1 p2) tol)) (defun at:doc () (if (not *AT-DOC*) (setq *AT-DOC* (vla-get-activedocument (vlax-get-acad-object)))) *AT-DOC* ) (defun at:mspace () (vla-get-modelspace (at:doc))) (defun at:lwp-points (ent / e pts pt) (setq pts '()) (foreach e (entget ent) (if (= (car e) 10) (setq pts (cons (list (cadr e) (caddr e) 0.0) pts)))) (setq pts (reverse pts)) (if (and (> (length pts) 1) (at:peq (car pts) (last pts) 1e-6)) (setq pts (reverse (cdr (reverse pts))))) pts ) (defun at:lwp-bulge (ent i / e idx b) (setq idx -1 b 0.0) (foreach e (entget ent) (cond ((= (car e) 10) (setq idx (1+ idx))) ((and (= (car e) 42) (= idx i)) (setq b (cdr e))))) b ) (defun at:lwp-closed-p (ent / flags) (setq flags (cdr (assoc 70 (entget ent)))) (= (logand flags 1) 1) ) (defun at:ent-area (ent / o) (setq o (vlax-ename->vla-object ent)) (vla-get-area o) ) (defun at:angles-collinear-p (a1 a2 tol) (or (< (abs (- a1 a2)) tol) (< (abs (- (abs (- a1 a2)) (* 2.0 pi))) tol)) ) ;;; ========================================================================= ;;; ARC -> CORNER ;;; ========================================================================= (defun at:arc-from-bulge (p1 p2 bulge / chord theta r mid n cx cy ang1 ang2 sign) (setq chord (at:dist2d p1 p2)) (setq theta (* 4.0 (atan (abs bulge)))) (setq r (/ chord (* 2.0 (sin (/ theta 2.0))))) (setq mid (list (/ (+ (car p1) (car p2)) 2.0) (/ (+ (cadr p1) (cadr p2)) 2.0) 0.0)) (setq n (list (/ (- (cadr p1) (cadr p2)) chord) (/ (- (car p2) (car p1)) chord))) (setq sign (if (> bulge 0) 1.0 -1.0)) (setq cx (+ (car mid) (* sign (car n) (sqrt (max 0.0 (- (* r r) (expt (/ chord 2.0) 2.0))))))) (setq cy (+ (cadr mid) (* sign (cadr n) (sqrt (max 0.0 (- (* r r) (expt (/ chord 2.0) 2.0))))))) (setq ang1 (atan (- (cadr p1) cy) (- (car p1) cx))) (setq ang2 (atan (- (cadr p2) cy) (- (car p2) cx))) (list (list cx cy 0.0) r ang1 ang2 (> bulge 0)) ) (defun at:line-intersect (p1 d1 p2 d2 / det tt1) (setq det (- (* (car d1) (cadr d2)) (* (cadr d1) (car d2)))) (if (< (abs det) 1e-9) nil (progn (setq tt1 (/ (- (* (- (car p2) (car p1)) (cadr d2)) (* (- (cadr p2) (cadr p1)) (car d2))) det)) (list (+ (car p1) (* tt1 (car d1))) (+ (cadr p1) (* tt1 (cadr d1))) 0.0))) ) (defun at:dir (p1 p2) (list (- (car p2) (car p1)) (- (cadr p2) (cadr p1)))) (defun at:make-lwpoly (pts-bulges closed layer color ltype / data pb) (setq data (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 layer) (cons 62 color) (cons 6 ltype) '(100 . "AcDbPolyline") (cons 90 (length pts-bulges)) (cons 70 (if closed 1 0)))) (foreach pb pts-bulges (setq data (append data (list (list 10 (car (car pb)) (cadr (car pb))) (cons 42 (cadr pb)))))) (entmakex data) (entlast) ) (defun at:point-in-poly (pt poly / inside i j n xi yi xj yj px py) (setq inside nil n (length poly) i 0 j (1- n) px (car pt) py (cadr pt)) (while (< i n) (setq xi (car (nth i poly)) yi (cadr (nth i poly))) (setq xj (car (nth j poly)) yj (cadr (nth j poly))) (if (and (not (eq (> yi py) (> yj py))) (< px (+ xi (* (/ (- xj xi) (- yj yi)) (- py yi))))) (setq inside (not inside))) (setq j i i (1+ i))) inside ) (defun at:segs-cross (p1 p2 p3 p4 / d1 d2 d3 d4) (defun side (a b c) (- (* (- (car b) (car a)) (- (cadr c) (cadr a))) (* (- (cadr b) (cadr a)) (- (car c) (car a))))) (setq d1 (side p3 p4 p1) d2 (side p3 p4 p2) d3 (side p1 p2 p3) d4 (side p1 p2 p4)) (and (or (and (> d1 0.0) (< d2 0.0)) (and (< d1 0.0) (> d2 0.0))) (or (and (> d3 0.0) (< d4 0.0)) (and (< d3 0.0) (> d4 0.0)))) ) (defun at:angle-of (p1 p2) (atan (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (defun at:merge-collinear (pts / out p prev-ang ang i n) (setq n (length pts) out (list (nth 0 pts)) i 1) (while (< i (1- n)) (setq prev-ang (at:angle-of (nth (1- i) pts) (nth i pts))) (setq ang (at:angle-of (nth i pts) (nth (1+ i) pts))) (if (not (at:angles-collinear-p ang prev-ang 0.001)) (setq out (cons (nth i pts) out))) (setq i (1+ i))) (setq out (cons (nth (1- n) pts) out)) (reverse out) ) (defun at:make-corner-region (pA pC pB bulge layer color ltype / pts-b) (setq pts-b (list (list pA bulge) (list pB 0.0) (list pC 0.0))) (at:make-lwpoly pts-b T layer color ltype) ) (defun at:hatch-entity (ent / ms hatch-obj obj-arr ename) (vl-catch-all-apply '(lambda () (setq ms (at:mspace)) (setq hatch-obj (vla-AddHatch ms 0 *AT-HATCH-PATTERN* :vlax-true)) (setq obj-arr (vlax-make-safearray vlax-vbObject '(0 . 0))) (vlax-safearray-put-element obj-arr 0 (vlax-ename->vla-object ent)) (vla-AppendOuterLoop hatch-obj obj-arr) (vla-put-PatternScale hatch-obj *AT-HATCH-SCALE*) (vla-put-Color hatch-obj *AT-HATCH-COLOR*) (vla-put-Layer hatch-obj *AT-LAYER*) ;; Set transparency to 70% (vl-catch-all-apply '(lambda () (vla-put-EntityTransparency hatch-obj "70"))) (vla-Evaluate hatch-obj) (setq ename (vlax-vla-object->ename hatch-obj)) (if ename (setq *AT-HATCH-LIST* (cons ename *AT-HATCH-LIST*))) )) ) (defun at:process-boundary (ent / pts n i bulges next-i prev-i segs cleaned corners new-pts pA pB ent-prev ent-next p-prev p-next d-prev d-next pC arc-info center inside? area-corner sign cent merged orig-area orig-pts-2d j) (setq pts (at:lwp-points ent) n (length pts) bulges '() i 0) (while (< i n) (setq bulges (cons (at:lwp-bulge ent i) bulges) i (1+ i))) (setq bulges (reverse bulges) orig-area (at:ent-area ent) orig-pts-2d (mapcar '(lambda (p) (list (car p) (cadr p))) pts) new-pts '() corners '() i 0) (while (< i n) (setq pA (nth i pts) pB (nth (rem (1+ i) n) pts)) (if (< (abs (nth i bulges)) 1e-9) (setq new-pts (cons pA new-pts)) (progn (setq prev-i (rem (+ i (1- n)) n) next-i (rem (1+ i) n) p-prev (nth prev-i pts) p-next (nth (rem (+ i 2) n) pts)) (setq d-prev (at:dir p-prev pA) d-next (at:dir pB p-next) pC (at:line-intersect pA d-prev pB d-next)) (if pC (progn (setq new-pts (cons pA new-pts) new-pts (cons pC new-pts)) (setq cent (at:make-corner-region pA pC pB (nth i bulges) *AT-LAYER* *AT-COL-CORNER* *AT-LT-CORNER*)) (setq area-corner (at:ent-area cent) arc-info (at:arc-from-bulge pA pB (nth i bulges)) center (car arc-info) inside? (at:point-in-poly center orig-pts-2d)) (setq sign (if inside? -1.0 1.0)) (setq corners (cons (list (* sign area-corner) cent inside?) corners)) (at:hatch-entity cent)) (setq new-pts (cons pA new-pts))) )) (setq i (1+ i))) (setq new-pts (reverse new-pts) merged (at:merge-collinear new-pts)) (list merged (reverse corners) orig-area orig-pts-2d) ) ;;; ========================================================================= ;;; QUAD ANALYSIS ;;; ========================================================================= (defun at:perp-foot (P A B / dx dy len2 tt fx fy) (setq dx (- (car B) (car A)) dy (- (cadr B) (cadr A)) len2 (+ (* dx dx) (* dy dy))) (if (< len2 1e-12) (list A 0.0) (progn (setq tt (/ (+ (* (- (car P) (car A)) dx) (* (- (cadr P) (cadr A)) dy)) len2)) (setq fx (+ (car A) (* tt dx)) fy (+ (cadr A) (* tt dy))) (list (list fx fy 0.0) tt))) ) (defun at:diag-score (Adi Bdi P1 P2 / f1 f2 tt1 tt2 inside1 inside2 d1 d2 len) (setq f1 (at:perp-foot P1 Adi Bdi) f2 (at:perp-foot P2 Adi Bdi) tt1 (cadr f1) tt2 (cadr f2)) (setq inside1 (and (> tt1 0.0) (< tt1 1.0)) inside2 (and (> tt2 0.0) (< tt2 1.0)) len (at:dist2d Adi Bdi)) (if (and inside1 inside2) (- len) (progn (setq d1 (cond ((< tt1 0.0) (- 0.0 tt1)) ((> tt1 1.0) (- tt1 1.0)) (T 0.0))) (setq d2 (cond ((< tt2 0.0) (- 0.0 tt2)) ((> tt2 1.0) (- tt2 1.0)) (T 0.0))) (+ 1000.0 d1 d2))) ) (defun at:analyze-quad (q / v1 v2 v3 v4 sA sB chosen Adi Bdi P1 P2 f1 f2) (setq v1 (nth 0 q) v2 (nth 1 q) v3 (nth 2 q) v4 (nth 3 q) sA (at:diag-score v1 v3 v2 v4) sB (at:diag-score v2 v4 v1 v3)) (if (<= sA sB) (setq chosen 'A Adi v1 Bdi v3 P1 v2 P2 v4) (setq chosen 'B Adi v2 Bdi v4 P1 v1 P2 v3)) (setq f1 (at:perp-foot P1 Adi Bdi) f2 (at:perp-foot P2 Adi Bdi)) (list Adi Bdi (car f1) P1 (car f2) P2 (at:dist2d Adi Bdi) (at:dist2d P1 (car f1)) (at:dist2d P2 (car f2))) ) (defun at:analyze-triangle (q / v1 v2 v3 sides ix Adi Bdi Papex foot) (setq v1 (nth 0 q) v2 (nth 1 q) v3 (nth 2 q) sides (list (at:dist2d v1 v2) (at:dist2d v2 v3) (at:dist2d v3 v1))) (setq ix (cond ((and (>= (nth 0 sides) (nth 1 sides)) (>= (nth 0 sides) (nth 2 sides))) 0) ((>= (nth 1 sides) (nth 2 sides)) 1) (T 2))) (cond ((= ix 0) (setq Adi v1 Bdi v2 Papex v3)) ((= ix 1) (setq Adi v2 Bdi v3 Papex v1)) (T (setq Adi v3 Bdi v1 Papex v2))) (setq foot (at:perp-foot Papex Adi Bdi)) (list Adi Bdi (car foot) Papex Papex Papex (at:dist2d Adi Bdi) (at:dist2d Papex (car foot)) 0.0) ) (defun at:quads-equal (q1 q2 tol / matched p) (if (/= (length q1) (length q2)) nil (progn (setq matched T) (foreach p q1 (if (not (vl-some '(lambda (v) (at:peq p v tol)) q2)) (setq matched nil))) matched)) ) (defun at:quad-already-defined-p (q quads tol / found) (setq found nil) (foreach existing quads (if (at:quads-equal q existing tol) (setq found T))) found ) (defun at:shoelace-area (pts / n i a b sum) (setq n (length pts) sum 0.0 i 0) (while (< i n) (setq a (nth i pts) b (nth (rem (1+ i) n) pts) sum (+ sum (- (* (car a) (cadr b)) (* (car b) (cadr a)))) i (1+ i))) (/ (abs sum) 2.0) ) (defun at:quad-self-intersects-p (q) (or (at:segs-cross (nth 0 q) (nth 1 q) (nth 2 q) (nth 3 q)) (at:segs-cross (nth 1 q) (nth 2 q) (nth 3 q) (nth 0 q))) ) ;;; ========================================================================= ;;; ORIGINAL DIMENSIONS (Outer Offset & Collinear Merge) ;;; ========================================================================= ;;; ========================================================================= ;;; USER INPUT (FREE CLICKS + POST-VALIDATION) ;;; ========================================================================= (defun at:get-boundary ( / e ent obj) (princ "\nSelect closed boundary polyline: ") (setq e (entsel)) (if (null e) (progn (princ "\nNothing selected. Aborting.") nil) (progn (setq ent (car e)) (cond ((not (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")) (princ "\nERROR: selection is not an LWPOLYLINE.") nil) ((not (at:lwp-closed-p ent)) (princ "\nERROR: polyline is not closed.") nil) (T ent)))) ) (defun at:process-and-draw-quad (qnum quad-pts q-col bpoly-ent / analysis area obj n) (setq n (length quad-pts)) (setq analysis (cond ((= n 3) (at:analyze-triangle quad-pts)) ((= n 4) (at:analyze-quad quad-pts)) (T (princ (strcat "\nINTERNAL: cannot analyze " (itoa n) "-vertex region.")) nil))) (if (null analysis) nil (progn (if bpoly-ent (progn (setq obj (vlax-ename->vla-object bpoly-ent)) (vla-put-Layer obj *AT-LAYER*) (vla-put-Color obj q-col) (vl-catch-all-apply 'vla-put-Linetype (list obj *AT-LT-QUAD*)))) (at:draw-quad-geometry qnum analysis q-col) (setq area (* 0.5 (nth 6 analysis) (+ (nth 7 analysis) (nth 8 analysis)))) (list qnum (nth 6 analysis) (nth 7 analysis) (nth 8 analysis) area))) ) (defun at:get-quads-interactive (clean-pts clean-area / quads-pts results qnum continue? done-area remaining-area quad-pts pt k aborted temp-marks tm bpoly-ent area-msg invalid error-msg) (setq quads-pts '() results '() qnum 1) (princ "\n--- Quadrilateral definition phase ---") (setq continue? T) (while continue? (setq done-area 0.0) (foreach r results (setq done-area (+ done-area (nth 4 r)))) (setq remaining-area (- clean-area done-area) area-msg (strcat " [done " (at:fmt done-area) " / rem " (at:fmt remaining-area) "]")) (setq quad-pts '() aborted nil temp-marks '() k 1) (while (and (not aborted) (<= k 4)) (princ (strcat "\nQuad #" (itoa qnum) " - point " (itoa k) " of 4" (if (= k 1) " (Enter to finish):" ":") area-msg)) (setq pt (getpoint)) (cond ((null pt) (cond ((= k 1) (setq aborted T continue? nil)) (T (princ "\nQuad cancelled. Restarting.") ;; Clean up temp marks for cancelled quad (foreach tm temp-marks (entdel tm)) (setq quad-pts '() temp-marks '() k 1 aborted nil)))) (T (setq pt (at:flat pt)) (setq quad-pts (append quad-pts (list pt))) (setq tm (entmakex (list '(0 . "POINT") (cons 8 *AT-LAYER*) (cons 62 3) (cons 10 pt)))) (setq temp-marks (cons tm temp-marks)) (princ (strcat " -> picked: (" (at:fmt (car pt)) ", " (at:fmt (cadr pt)) ")")) (setq k (1+ k))))) (if (and (not aborted) continue? (= (length quad-pts) 4)) (progn (setq invalid nil error-msg "") (cond ((at:quad-self-intersects-p quad-pts) (setq invalid T error-msg "Bow-tie quad.")) ((< (at:shoelace-area quad-pts) 1e-6) (setq invalid T error-msg "Degenerate quad.")) ((at:quad-already-defined-p quad-pts quads-pts *AT-TOL-VERTEX*) (setq invalid T error-msg "Already defined.")) ) (if invalid (progn (princ (strcat "\nERROR: " error-msg " Please try again.")) ;; Delete points if invalid (foreach tm temp-marks (entdel tm))) (progn ;; Valid Quad - Add points to global persistance list instead of deleting (setq *AT-GLOBAL-MARKS* (append temp-marks *AT-GLOBAL-MARKS*)) (setq quads-pts (cons quad-pts quads-pts)) (setq bpoly-ent (at:make-lwpoly (mapcar '(lambda (p) (list p 0.0)) quad-pts) T *AT-LAYER* *AT-COL-QUAD* *AT-LT-QUAD*)) (setq results (cons (at:process-and-draw-quad qnum quad-pts *AT-COL-QUAD* bpoly-ent) results)) (princ (strcat "\nQuad #" (itoa qnum) " accepted and drawn.")) (setq qnum (1+ qnum)))))) ) (reverse results) ) ;;; ========================================================================= ;;; DRAWING: Geometry & Text Styles ;;; ========================================================================= (defun at:ensure-textstyle-bold (font / styles s found-name) (vl-catch-all-apply '(lambda () (setq styles (vla-get-TextStyles (at:doc)) found-name nil) (vlax-for s styles (if (and (not found-name) (= (strcase (vla-get-Name s)) (strcase (strcat "AT_" font "_Bold")))) (setq found-name (vla-get-Name s)))) (if (not found-name) (progn (setq found-name (strcat "AT_" font "_Bold") s (vla-Add styles found-name)) (vla-SetFont s font :vlax-true :vlax-false 0 34))) found-name)) ) (defun at:draw-quad-geometry (qnum analysis quad-color / Adi Bdi f1 P1 f2 P2 base w1 w2 mid text-style) (setq Adi (nth 0 analysis) Bdi (nth 1 analysis) f1 (nth 2 analysis) P1 (nth 3 analysis) f2 (nth 4 analysis) P2 (nth 5 analysis) base (nth 6 analysis) w1 (nth 7 analysis) w2 (nth 8 analysis)) (entmakex (list '(0 . "LINE") (cons 8 *AT-LAYER*) (cons 62 *AT-COL-QUAD*) (cons 6 *AT-LT-QUAD*) (cons 10 Adi) (cons 11 Bdi))) (entmakex (list '(0 . "LINE") (cons 8 *AT-LAYER*) (cons 62 *AT-COL-QUAD*) (cons 6 *AT-LT-QUAD*) (cons 10 P1) (cons 11 f1))) (if (> w2 1e-9) (entmakex (list '(0 . "LINE") (cons 8 *AT-LAYER*) (cons 62 *AT-COL-QUAD*) (cons 6 *AT-LT-QUAD*) (cons 10 P2) (cons 11 f2)))) (setq mid (if (> w2 1e-9) (list (/ (+ (car Adi) (car Bdi) (car P1) (car P2)) 4.0) (/ (+ (cadr Adi) (cadr Bdi) (cadr P1) (cadr P2)) 4.0) 0.0) (list (/ (+ (car Adi) (car Bdi) (car P1)) 3.0) (/ (+ (cadr Adi) (cadr Bdi) (cadr P1)) 3.0) 0.0))) (setq text-style (at:ensure-textstyle-bold *AT-TABLE-FONT*)) (entmakex (list '(0 . "TEXT") (cons 8 *AT-LAYER*) (cons 62 *AT-COL-QUADNUM*) (cons 7 text-style) (cons 10 mid) (cons 40 *AT-TXT-QUADNUM*) (cons 1 (itoa qnum)) (cons 72 1) (cons 73 2) (cons 11 mid))) (at:dim-aligned Adi Bdi) (at:dim-aligned P1 f1) (if (> w2 1e-9) (at:dim-aligned P2 f2)) ) (defun at:dim-aligned (p1 p2 / mid dx dy norm nx ny offset-pt) (setq mid (list (/ (+ (car p1) (car p2)) 2.0) (/ (+ (cadr p1) (cadr p2)) 2.0) 0.0)) (setq dx (- (car p2) (car p1)) dy (- (cadr p2) (cadr p1)) norm (sqrt (+ (* dx dx) (* dy dy)))) (if (> norm 1e-9) (progn (setq nx (/ (- 0 dy) norm) ny (/ dx norm)) (setq offset-pt (list (+ (car mid) (* 0.75 nx)) (+ (cadr mid) (* 0.75 ny)) 0.0)) (command "._DIMALIGNED" p1 p2 offset-pt) ) ) ) ;;; ========================================================================= ;;; TABLE (native CAD TABLE entity) ;;; ========================================================================= (setq *AT-COLS* (list "FP No." "Quad No." "Type" "Long L1" "Long L2" "Long Total" "Width L1" "Width L2" "Width Total" "Mult." "Area" "Remarks")) (setq *AT-COL-WS-REL* '(0.067 0.067 0.067 0.083 0.083 0.083 0.083 0.083 0.083 0.100 0.100 0.100)) (defun at:draw-table (ins data-rows corner-rows final-total-str / n-data n-corner n-rows n-cols row-h title-h hdr-h col-widths total-w tbl ms i j r col-w title-row hdr-row summary-row final-row style-name) (setq n-data (length data-rows) n-corner (length corner-rows) n-cols 12 n-rows (+ 2 n-data n-corner 2) row-h *AT-TABLE-ROW-H* title-h (* 1.6 *AT-TABLE-ROW-H*) hdr-h (* 1.2 *AT-TABLE-ROW-H*) total-w *AT-TABLE-WIDTH* col-widths (mapcar '(lambda (x) (* x total-w)) *AT-COL-WS-REL*)) (setq ms (at:mspace) tbl (vla-AddTable ms (vlax-3d-point ins) n-rows n-cols row-h (/ total-w n-cols))) (setq j 0) (foreach col-w col-widths (vla-SetColumnWidth tbl j col-w) (setq j (1+ j))) (vla-SetRowHeight tbl 0 title-h) (vla-SetRowHeight tbl 1 hdr-h) (setq i 2) (while (< i n-rows) (vla-SetRowHeight tbl i row-h) (setq i (1+ i))) (vl-catch-all-apply '(lambda () (setq style-name (at:ensure-textstyle *AT-TABLE-FONT*)) (if style-name (progn (setq i 0) (while (< i n-rows) (setq j 0) (while (< j n-cols) (vla-SetTextStyle tbl i j style-name) (setq j (1+ j))) (setq i (1+ i))))))) (setq title-row 0) (vla-MergeCells tbl title-row title-row 0 (1- n-cols)) (vla-SetText tbl title-row 0 "AREA TABLE") (vla-SetCellTextHeight tbl title-row 0 *AT-TXT-TABLE-TITLE*) (setq hdr-row 1 j 0) (foreach h *AT-COLS* (vla-SetText tbl hdr-row j h) (vla-SetCellTextHeight tbl hdr-row j *AT-TXT-TABLE-HDR*) (setq j (1+ j))) (setq r 0) (foreach row data-rows (setq j 0) (foreach cell row (vla-SetText tbl (+ 2 r) j cell) (vla-SetCellTextHeight tbl (+ 2 r) j *AT-TXT-TABLE-VAL*) (setq j (1+ j))) (setq r (1+ r))) (foreach row corner-rows (setq j 0) (foreach cell row (vla-SetText tbl (+ 2 r) j cell) (vla-SetCellTextHeight tbl (+ 2 r) j *AT-TXT-TABLE-VAL*) (setq j (1+ j))) (setq r (1+ r))) ;; Separated Summary Row (setq summary-row (+ 2 r) j 0) (while (< j n-cols) (vla-SetText tbl summary-row j (cond ((= j 9) "Area (Sq.mt.)") ((= j 10) final-total-str) (T ""))) (vla-SetCellTextHeight tbl summary-row j *AT-TXT-TABLE-VAL*) (setq j (1+ j))) (setq r (1+ r)) ;; Separated Final Row (setq final-row (+ 2 r) j 0) (while (< j n-cols) (vla-SetText tbl final-row j (cond ((= j 9) "Final Area") ((= j 10) (rtos (atof final-total-str) 2 0)) (T ""))) (vla-SetCellTextHeight tbl final-row j *AT-TXT-TABLE-VAL*) (setq j (1+ j))) (list tbl (- (cadr ins) title-h hdr-h (* (+ n-data n-corner 2) row-h))) ) (defun at:ensure-textstyle (font / styles s found-name) (vl-catch-all-apply '(lambda () (setq styles (vla-get-TextStyles (at:doc)) found-name nil) (vlax-for s styles (if (and (not found-name) (= (strcase (vla-get-FontFile s)) (strcase font))) (setq found-name (vla-get-Name s)))) (if (not found-name) (progn (setq found-name (strcat "AT_" font) s (vla-Add styles found-name)) (vla-SetFont s font :vlax-false :vlax-false 0 34))) found-name)) ) ;;; ========================================================================= ;;; MAIN COMMAND ;;; ========================================================================= (defun c:AREA_TO ( / ent processed clean-pts corners orig-area orig-pts quad-results data-rows corner-rows total-area q qnum ins-pt tbl-info tbl-bottom-y diff diff-pct compare-str base w1 w2 a c area-val inside? obj h auto-bpoly-ent ok auto-pts text-y) (vl-load-com) (setvar "CMDECHO" 0) (setq *AT-GLOBAL-MARKS* '()) (setq *AT-HATCH-LIST* '()) (setq ent (at:get-boundary)) (if (null ent) (progn (setvar "CMDECHO" 1) (princ) (exit))) (princ "\nProcessing boundary (arc->corner, merging collinear)...") (setq processed (at:process-boundary ent)) (setq clean-pts (nth 0 processed) corners (nth 1 processed) orig-area (nth 2 processed) orig-pts (nth 3 processed)) (at:make-lwpoly (mapcar '(lambda (p) (list p 0.0)) clean-pts) T *AT-LAYER* *AT-COL-CLEAN* *AT-LT-CLEAN*) (princ (strcat "\nCleaned polyline drawn. " (itoa (length clean-pts)) " vertices. Original area = " (at:fmt orig-area))) (princ (strcat "\n" (itoa (length corners)) " arc(s) closed.")) (cond ((= (length clean-pts) 4) (princ "\nCleaned polyline is already a quadrilateral - skipping diagonal phase.") (setq auto-bpoly-ent (at:make-lwpoly (mapcar '(lambda (p) (list p 0.0)) clean-pts) T *AT-LAYER* *AT-COL-QUAD* *AT-LT-QUAD*)) (setq quad-results (list (at:process-and-draw-quad 1 clean-pts *AT-COL-QUAD* auto-bpoly-ent)))) (T (setq quad-results (at:get-quads-interactive clean-pts (at:shoelace-area clean-pts))) (if (null quad-results) (progn (princ "\nNo quadrilaterals defined. Aborting.") (setvar "CMDECHO" 1) (princ) (exit))))) (setq data-rows '() total-area 0.0) (foreach q quad-results (setq qnum (nth 0 q) base (nth 1 q) w1 (nth 2 q) w2 (nth 3 q) a (nth 4 q) total-area (+ total-area a)) (setq data-rows (cons (list "" (itoa qnum) "" (at:fmt base) "" (at:fmt base) (at:fmt w1) (at:fmt w2) (at:fmt (+ w1 w2)) (at:fmt (* base (+ w1 w2))) (at:fmt a) "") data-rows))) (setq data-rows (reverse data-rows)) (setq corner-rows '()) (foreach c corners (setq area-val (nth 0 c) inside? (nth 2 c)) (setq corner-rows (cons (list "" "" "" "" "" "" (if inside? "Corner (Outer Side)" "Corner (Inner Side)") (if inside? "-1" "+1") (at:fmt (abs area-val)) "" (strcat (if inside? "-" "+") (at:fmt (abs area-val))) "") corner-rows)) (setq total-area (+ total-area area-val))) (setq corner-rows (reverse corner-rows)) (princ "\nClick insertion point for the area table (top-left corner): ") (setq ins-pt (getpoint)) (if (null ins-pt) (progn (princ "\nNo insertion point. Aborting.") (setvar "CMDECHO" 1) (princ) (exit))) (setq ins-pt (at:flat ins-pt)) (setq tbl-info (at:draw-table ins-pt data-rows corner-rows (at:fmt total-area)) tbl-bottom-y (cadr tbl-info)) (setq diff (- total-area orig-area) diff-pct (if (> (abs orig-area) 1e-9) (* 100.0 (/ diff orig-area)) 0.0)) (setq compare-str (strcat "Original Polyline Area = " (at:fmt orig-area) " | Computed Total = " (at:fmt total-area) " | Difference = " (at:fmt diff) " | Diff % = " (rtos diff-pct 2 3) "%")) (setq text-y (+ (cadr ins-pt) (* 1.5 *AT-TABLE-ROW-H*))) (entmakex (list '(0 . "TEXT") (cons 8 *AT-LAYER*) (cons 62 1) (cons 10 (list (car ins-pt) text-y 0.0)) (cons 40 *AT-TXT-COMPARE*) (cons 1 compare-str))) ;; Apply DRAWORDER to push all hatches backward (if *AT-HATCH-LIST* (foreach h *AT-HATCH-LIST* (if (entget h) (vl-catch-all-apply '(lambda () (command "._DRAWORDER" h "" "_B"))) ) ) ) ;; Delete all temporary green points (if *AT-GLOBAL-MARKS* (foreach tm *AT-GLOBAL-MARKS* (if (entget tm) (vl-catch-all-apply 'entdel (list tm))) ) ) ;; Keep Original Polyline, Set Color Red (1), Lineweight 0.35mm (35), and Bring to Front (vl-catch-all-apply '(lambda () (setq obj (vlax-ename->vla-object ent)) (vla-put-Color obj 1) (vla-put-Lineweight obj 35) (command "._DRAWORDER" ent "" "_F") )) (if (> (abs diff-pct) *AT-TOL-AREA-PCT*) (princ (strcat "\n*** SANITY CHECK FAILED: difference is " (rtos diff-pct 2 3) "%, exceeds tolerance of " (rtos *AT-TOL-AREA-PCT* 2 3) "%. Verify your quad partition. ***")) (princ (strcat "\nSanity check OK. Difference = " (rtos diff-pct 2 3) "%."))) (setvar "CMDECHO" 1) (princ "\nAREA_TO complete.") (princ) ) (princ "\nAREA_TO loaded. Type AREA_TO to start.") (princ)