Get Area
;|
Code Get Area m2 and ri-ng-wa
- Enter Text height
- Pick point in Area :
- Create and Design by SONGKHRAN JONGKUL September 2025
- Contact https://www.facebook.com/groups/AutolispTH"
|;
;;------------------------------------------------------------+
(defun c:GAR(/ ins ss ptt area_t ar_th txt clor tot_area )
(setq old_cecolor (getvar "cecolor"))
(setq old_cmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq txstyle "Area_TH")
(if (not(tblsearch "style" txstyle))
(vl-cmdf "_style" txstyle "FreesiaUPC" "" "" "0" "" "") ; Front Thai FreesiaUPC
)
(setvar "textstyle" txstyle) ;;Current Style
;;----------Text Height--------
(or txth (setq txth 0.250))
(setq txthtemp
(getDist (strcat "\nText Height : <"
(rtos txth 2 2)
">: "
) ;_ strcat
) ;_ getdist
) ;_ setq
(and txthtemp (setq txth txthtemp))
;;------------------------------------
(setq clor 1) ;start colour 1 red
(setq dec 3) ;decimal 3
(while(setq ins (getpoint "\nPick point in Area : "))
(setvar "cecolor" (rtos clor 2 0))
(vl-cmdf "_boundary" ins "")
(setq ss (ssget "L"))
(setq ptt(LM:PolyCentroid (ssname ss 0)))
(vl-cmdf "_area" "o" (ssname ss 0))
(setq area_t (getvar "area"))
;;(vl-cmdf "_erase" (ssname ss 0) "") ;;delete boundary
(setq ar_th (areath area_t))
(setq txt (strcat (rtoc area_t dec)" ตร.ม."
"\n" ar_th " ไร่-งาน-ตารางวา")
)
(setvar "cecolor" old_cecolor)
(entmake
(list
'(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 10 ptt)
(cons 7 txstyle)
(cons 40 txtH)
(cons 41 0) ; 0 Width = no wrap
(cons 71 5) ; 5=Middle Center
(cons 50 0.0) ; rotation angle
(cons 1 txt)
(cons 62 clor) ; colour
)
)
(setq clor (1+ clor))
);while
(setvar "cmdecho" old_cmdecho)
(setvar "cecolor" old_cecolor)
(princ)
)
;;Converse area square meter to Thai area
(defun areath (sqm / rl_r rl_ng rl_wa th_area)
(setq rl_r (fix(/ sqm 1600.00)))
(setq rl_ng (fix(/ (- sqm (* rl_r 1600.00)) 400.00)))
(setq rl_wa (/ (- sqm (+ (* rl_r 1600.00) (* rl_ng 400.00))) 4))
(setq th_area (strcat (rtos rl_r 2 0) "-"(rtos rl_ng 2 0) "-" (rtos rl_wa 2 2)))
)
;;Add comma to Number 1,000,000.00
(defun rtoc ( n p / d i l x );; n = any number p = precision
(setq l (vl-string->list (rtos n 2 p))
x (cond ((cdr (member 46 (reverse l)))) ((reverse l)))
i 0
)
(vl-list->string
(append
(reverse
(apply 'append
(mapcar
'(lambda ( a b )
(if (and (zerop (rem (setq i (1+ i)) 3)) b)
(list a 44)
(list a)
)
)
x (append (cdr x) '(nil))
)
)
)
(member 46 l)
)
)
);end
;; Polygon Centroid - Lee Mac
;; Returns the WCS Centroid of an LWPolyline Polygon Entity
(defun LM:PolyCentroid ( e / l )
(foreach x (setq e (entget e))
(if (= 10 (car x)) (setq l (cons (cdr x) l)))
)
(
(lambda ( a )
(if (not (equal 0.0 a 1e-8))
(trans
(mapcar '/
(apply 'mapcar
(cons '+
(mapcar
(function
(lambda ( a b )
(
(lambda ( m )
(mapcar
(function
(lambda ( c d ) (* (+ c d) m))
)
a b
)
)
(- (* (car a) (cadr b)) (* (car b) (cadr a)))
)
)
)
l (cons (last l) l)
)
)
)
(list a a)
)
(cdr (assoc 210 e)) 0
)
)
)
(* 3.0
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car a) (cadr b)) (* (car b) (cadr a)))
)
)
l (cons (last l) l)
)
)
)
)
)
ไม่มีความคิดเห็น:
แสดงความคิดเห็น