วันเสาร์ที่ 19 ธันวาคม พ.ศ. 2563

Get Area4

 

(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

 

(defun c:GAR(/ clor tot_area )

(setq old_cecolor (getvar "cecolor"))

(setq old_cmdecho  (getvar "cmdecho"))

 

(setvar "cmdecho" 0)

(setq clor 1) ;start colour 1 red

(setq dec 3)  ;decimal 3

 

(initget "1 2")

       (setq opt_ar (getkword "\nSelect Options : \n [1  Rai-Ngan-Wah / 2  square metre.] <1> "))

       (if (= opt_ar "")(setq opt_ar "1"))

(initget "1 2")

       (setq opt (getkword "\nSelect Options : \n [1  Pick in Area. / 2  Select Polyline Closed.] <1> "))

       (if (= opt "")(setq opt "1"))

(initget "Yes No")

       (setq opt_ab (getkword "\nAuto Boundary : \n [Yes / No] <Yes> "))

       (if (= opt_ab "")(setq opt_ab "Yes"))

(setq txtH 10.0); Current height

(setq txtS (getvar "textstyle")); Current Style

(setq ins 1)

(setq tot_area 0.0)

 

(if (= opt "1")

(while (setq ins (getpoint "\nPick in Area: "))

       (setvar "cecolor" (rtos clor 2 0))

       (command "_boundary" ins "")   

       (command "_area" "o" "l")

       (if (= opt_ab "No")(command "_erase" "l" ""))

       (setq tot_area (+ tot_area (getvar "area")))

       (setq clor (1+ clor))

);while

);if opt "1"

(if (= opt "2")

       (if (setq ss1 (ssget '((-4 . "<OR")

                         (0 . "POLYLINE")

                         (0 . "LWPOLYLINE")

                         (0 . "CIRCLE")

                         (0 . "ELLIPSE")

                         (0 . "SPLINE")

                         (0 . "REGION")

                         (-4 . "OR>")

                        )

                                  )

              )

              (progn

                     (setq nr 0)

                     (setq en (ssname ss1 nr))

                     (while en

                           (command "._area" "_O" en)

                           (command "_chprop" en "" "Color" clor "")

                           (setq tot_area (+ tot_area (getvar "area")))

                           (setq nr (1+ nr))

                           (setq en (ssname ss1 nr))

                           (setq clor (1+ clor))

                     );while

              )

       )

);if opt "2"

(if (= opt_ar "1")

       (setq txt (areath tot_area))

       (setq txt (strcat (rtoc tot_area dec)" m\U+00B2")) ;add , comma

)     

       (setq pt (getpoint "\n Pick Area Location: "))

       (setvar "cecolor" old_cecolor)

       (entmake

              (list

                     '(0 . "MTEXT")

                     '(100 . "AcDbEntity")

                     '(100 . "AcDbMText")

                     (cons 10 pt)

                     (cons 7  txtS)

                     (cons 40 txtH) 

                     (cons 41 0) ; 0 Width = no wrap

                     (cons 71 5) ; 1=Top Left   /2=Top Center   /3= Top Right

                                         ; 4=Middle Left/5=Middle Center/6=Middle Right

                                         ; 7=Bottom Left/8=Bottom Center/9=Bottom Right

                     (cons 50 0.0) ; rotation angle

                     (cons 1 txt)

              )

       )

(setvar "cmdecho" old_cmdecho)

(setvar "cecolor" old_cecolor)

(princ)

)

(prompt "\nEnter GAR to Start Get Area.")

 

(defun areath (sqm / rl_r rl_ng rl_wa th_area)

       (setq rl_r (fix(/ sqm 1600)))

       (setq rl_ng (fix(/ (- sqm (* rl_r 1600)) 400)))

       (setq rl_wa (/ (- sqm (+ (* rl_r 1600) (* rl_ng 400))) 4))

       (setq th_area (strcat (rtos rl_r 2 0) "-"(rtos rl_ng 2 0) "-" (rtos rl_wa 2 2)))                                   

)


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

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