AREA TH HATCH
area_th อันนี้เพิ่มตัวเลือก Hacth โดยใช้ตัว getkword ทำไว้ให้ดูสองแบบ
- อันแรกแบบถาม YES or NO.
- อันที่สองเป็นการเลือกแบบหลายตัวเลือกโดยทำไว้เป็นตัวอย่าง 4 ตัวเลือกเป็นชื่อ Pattern Name. โดยสามรถเพิ่มเติมได้ตามต้องการ
ไว้ตัวอย่างต่อไปจะเพิ่มตำแหน่ง Coordinate X Y or N E ให้ด้วย
;|
Code Get Area m2 and ri-ng-wa
- Options Hacth Yes or No.
- Options Pattern Name
- 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
;;---------------Options Hatch-----------------+
(initget "YES NO")
(setq Opt_ht (getkword "\nDo You Want Hatch : [ YES / NO ] :<YES>"))
(if 
Opt_ht "")(setq Opt_ht "YES"))
Opt_ht "")(setq Opt_ht "YES"))(if (equal Opt_ht "YES")
(progn
(initget "1 2 3 4")
(setq ptname (getkword "\nSelect Pattern Name : [ 1 ANSI37 / 2 AR-CONC / 3 AR-SAND / 4 EARTH ] :<1>"))
(if ( = ptname "")(setq ptname "1"))
(cond
(( = ptname "1")(setq pthname "ANSI37"))
(( = ptname "2")(setq pthname "AR-CONC"))
(( = ptname "3")(setq pthname "AR-SAND"))
(( = ptname "4")(setq pthname "EARTH"))
)
;;---setting hatch vaule------+
(setq hp (getvar "hpname"))
(setvar "hpname" pthname) ;;<--hatch pattern name
(setq ha (getvar "hpassoc"))
(setvar "hpassoc" 1) ;;<--set hatch associative 1 on / 0 off
(setq hs (getvar "hpscale"))
(setvar "hpscale" 2.0) ;;<--set hatch pattern scale
)
)
;;----------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"))
;;--------Hatch drawing--------------------------+
(if (equal Opt_ht "YES")
(vl-cmdf "._-hatch" "_S" (ssname ss 0) "" "")
)
;;-----------------------------------------------+
(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
;;---Resetting hatch vaule------+
(if (equal Opt_ht "YES")
(progn
(setvar "hpname" hp) ;<-- restore hatch patter name
(setvar "hpassoc" ha) ;<-- restore hatch asociativity
(setvar "hpscale" hs) ;<-- restore hatch patter scale
)
)
(setvar "cmdecho" old_cmdecho)
(setvar "cecolor" old_cecolor)
(princ)
)
(prompt "\n\t\t\t +------------------------------------------+\n")
(prompt "\n\t\t\t | Start with GAR to execute |\n")
(prompt "\n\t\t\t +------------------------------------------+\n")
;;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)))
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)
)
)
)
)
)
ไม่มีความคิดเห็น:
แสดงความคิดเห็น