วันจันทร์ที่ 8 กันยายน พ.ศ. 2568

AREA TH COORDINATE

 

AREA TH COORDINATE

area_th ตัวนี้เพิ่ม Coordinate NE และให้ด้วยและส่งออกไป Excel.CSV ด้วย getkword อีกสองตัวคือ

  • เลือกว่าจะใส่ค่า Coordinate หรือไม่ YES / NO
  • เลือกว่าจะส่งค่าไป Excel.CSV หรือไม่ YES / NO
;|
Code Get Area m2 and ri-ng-wa
- Options Coordinate Yes or No.
- Options Send to Excel.CSV Yes or No.
- 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 Coordinate-----------------+
(initget "YES NO")
(setq Opt_co (getkword "\nDo You Want Coordinate : [ YES / NO ] :<YES>"))
(if ( = Opt_co "")(setq Opt_co "YES"))
;;---------------Options Coordinate-----------------+
(initget "YES NO")
(setq Opt_csv (getkword "\nSend to Excel.CSV : [ YES / NO ] :<YES>"))
(if ( = Opt_csv "")(setq Opt_csv "YES"))
;;---------------Options Hatch-----------------+
(initget "YES NO")
(setq Opt_ht (getkword "\nDo You Want Hatch : [ YES / NO ] :<YES>"))
(if ( = 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 lst_pt(list)) ;gobal list
(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"))
(setq ar_th (areath area_t))
(setq txt (strcat (rtoc area_t dec)" ตร.ม."
"\n" ar_th " ไร่-งาน-ตารางวา")
)
(myMtext ptt txstyle txtH txt clor)
;;--------Hatch drawing--------------------------+
(if (equal Opt_ht "YES")
(vl-cmdf "._-hatch" "_S" (ssname ss 0) "" "")
)
;;--------Get Coordinate list--------------------------+
(if (equal Opt_co "YES")
(progn
(setq num 1)
(setq lst_pt (mapcar 'cdr (vl-remove-if-not '(lambda (x) ( = (car x) 10)) (entget (ssname ss 0)))))
(foreach x lst_pt
(entmake
(list
'(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 10 x)
(cons 7  txstyle)
(cons 40 txtH) 
(cons 41 0) ; 0 Width = no wrap
(cons 71 7) ; 7=Bottom Left
(cons 50 0.0) ; rotation angle
(cons 1 (strcat (rtos num 2 0) ". N = "(rtos (cadr x)2 dec) "\n   E = "(rtos (car x)2 dec)))
(cons 62 256) ; colour
)
)
(setq num (1+ num))
)
)
)
;;----------Send to Excel File.CSV------------------------+
(if (equal Opt_csv "YES")
(progn
(setq number 1)
(if (and(setq fn (getfiled "Save to Excel.CSV" (getvar 'DWGPREFIX) "csv" 1))
(setq of (open fn "w"))
)
(foreach XY lst_pt
(write-line 
(strcat (rtos number 2 0) "," 
(rtos (car XY)) "," 
(rtos (cadr XY) )"," 
of
)
(setq number (1+ number))
)
)
(close of)
(alert (strcat "File: \n\n[" Fn "]\n\nhas been created."))
)
)
;;-----------------------------------------------------------+
(vl-cmdf "_erase" (ssname ss 0) "") ;;delete boundary
(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")
(defun myMtext (ptt txstyle txtH txt clor)
(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
            )
)
)
;;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)
                )
            )
        )
    )
)

ไม่มีความคิดเห็น:

แสดงความคิดเห็น