วันพุธที่ 25 พฤศจิกายน พ.ศ. 2563

Point or Circle Closest To Text CC2TZ

 

;|      25-11-2020

       Point or Circle Closest To Text CC2TNEZ

       change text to mtext for 3D coordinate

       add table Z ( elevations)

|;

 

(defun c:cc2tz ( / points texts i j pt ind dst d result)

(setq old_cmdecho  (getvar "cmdecho"))

(setvar "cmdecho" 0)

       (setq txtH (getvar "TEXTSIZE"))

       (setq txtS (getvar "textstyle"))

(initget "1 2 3")

       (setq opt (getkword "\nSelect Options : \n [1  Pick points. / 2  Select object. / 3  Find All. ] <1> "))

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

(if (or(= opt "1")(= opt "2"))

       (progn

;;-----------Enter String Symbol -----

       (if (null sta)(setq sta "A"))

       (setq statemp (getstring (strcat "\n Enter String Symbol <"  sta ">: ")))

       (if (eq statemp "")

              (setq statemp sta)

              (setq sta statemp)

       )

;;----------Number Start Count--------

       (or nma (setq nma 1))

        (setq nmatemp

            (getDist (strcat "\nEnter Number : <"

                             (rtos nma 2 0)

                                     ">: "

                     ) ;_ strcat

            ) ;_ getdist

        ) ;_ setq

    (and nmatemp (setq nma nmatemp))

       );;progn

);;if

;;------------------------------------ 

(if (= opt "1")

       (progn

       (while(setq pt (getpoint "\nPick Points :"))          

              (setq txt (strcat " " (strcase sta) (rtos nma 2 0)))

              (metxt pt 7 txth 0 txt)

              (setq result

                     (append result

                           (list

                                  (list

                                         txt          ;; text

                                         (car pt)      ;; x value of point

                                         (cadr pt)     ;; y value of point 

                                         (caddr pt)    ;; z value of point

                                  )

                           )

                     )

              )

              (setq nma (1+ nma))

       )

       (setq lst1 result)

       )

);if = Pick   points

;;-----------------------------

(if (= opt "2")

       (progn

              (princ "\n Select circle mark.")

              (if (setq ss (ssget '((0 . "POINT,CIRCLE"))))

                     (progn

                           (setq ctr 0

                                    numss (sslength ss)

                           )

                           (repeat (setq in (sslength ss))

                                  (setq pt (cdr (assoc 10 (entget (ssname ss (setq in (1- in)))))))            

                                  (setq txt (strcat " " (strcase sta) (rtos nma 2 0)))

                                  (metxt pt 7 txth 0 txt)

                                  (setq result

                                         (append result

                                                (list

                                                       (list

                                                              txt          ;; text

                                                              (car pt)      ;; x value of point

                                                              (cadr pt)     ;; y value of point 

                                                              (caddr pt)    ;; z value of point

                                                       )

                                                )

                                         )

                                  )

                                  (setq nma (1+ nma))

                                  (setq ctr (1+ ctr))

                           )

                           (setq lst1 result)

                     )

              )

       )

)

;;-----------------------------

(if (= opt "3")

       (progn

       (initget "1 2")

       (setq opt1 (getkword "\nSelect Options : \n [ 1 Point / 2 Circle ] <1> "))

       (if (= opt1 "")(setq opt1 "1"))

       (if (= opt1 "1")

              (setq points (ssget "_X" '((0 . "POINT"))))

              (setq points (ssget "_X" '((0 . "CIRCLE"))))

       )

       (setq texts  (ssget "_X" (list (cons 0 "MTEXT,TEXT"))))

 

       (setq i 0)

       (setq result (list))

       (repeat (sslength points)

              (setq j 0)

              (setq dst nil)  ;; this will hold the closest distance.  If a new closer distance is found we replace dst by that new value

              (setq ind nil)

              (repeat (sslength texts)

                     (setq d (distance

                                         (setq pt (cdr (assoc 10 (entget (ssname points i)))))  ;; insert point of the point

                                         (cdr (assoc 10 (entget (ssname texts j))))             ;; insert point of the text

                                  )

                     )

                     (if (or (= dst nil) (< d dst))

                           (progn

                                  (setq dst d)

                                  (setq ind j)

                           )

                     )

                     (setq j (+ j 1))

              )

   

              (setq result

                     (append result

                           (list

                                  (list

                                         (cdr (assoc 1 (entget (ssname texts ind))))   ;; text

                                         (nth 0 pt)                                    ;; x value of point

                                         (nth 1 pt)                                    ;; y value of point

                                         (nth 2 pt)                                                             ;; z value of point

                                  )

                           )

                     )

              )

      

              (ssdel  (ssname texts ind) texts)  ;; to exclude TEXT that is already paired on the next loop

              (setq i (+ i 1))

       )

       (setq lst1 (reverse result))

       )

)

  (print_table lst1)

(setvar "cmdecho" old_cmdecho)

(princ)

 

);;end

(prompt "\nEnter CC2TZ to start Circle Closest to text.")

;;------------------------------------------------------

(defun metxt (pt pos txth ang txt);;Mtext Maker

              (entmake

                     (list

                           (cons 0 "MTEXT")

                           (cons 100 "AcDbEntity")

                           (cons 100 "AcDbMText")

                           (cons 7 "txtS");;fontstyle

                           (cons 8 "CC2T_NEZ");;Layer nmae

                           (cons 71 pos) ; 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 72 5)

                           (cons 73 1)

                           (cons 10 pt);;Text point

                           (cons 11 (list 1.0 0.0 0.0))

                           (cons 50 ang);;Angle Radial only

                           ;(cons 41 19.35)

                           (cons 40 TXTH);;Text Height

                           (cons 44 1.0)

                           (cons 1 TXT);;Text String

                     );list               

              );entmake

)

;;------------------------------------------------------

(defun print_table (lst / )

(setq old_osnap (getvar "osmode"))  ; osnap

(setq old_layer (getvar "clayer")) ;  layer

(setvar "osmode" 0)

       (setq pt0 (getpoint "\nPick a table point :")

                txth (getvar "TEXTSIZE")

                dec 3

                num 0

                nump (length lst)

       )

       (setq pt1  (list (+(car pt0)(* txth 10))(cadr pt0))

                ptx1 (list (+(car pt0)(* txth 5)) (-(cadr pt0)(* txth 1.0)))

                pt2  (list (+(car pt1)(* txth 10))(cadr pt1))

                ptx2 (list (+(car pt1)(* txth 5)) (-(cadr pt1)(* txth 1.0)))

                pt3  (list (+(car pt2)(* txth 10))(cadr pt2))

                ptx3 (list (+(car pt2)(* txth 5)) (-(cadr pt2)(* txth 1.0)))

                pt4  (list (+(car pt3)(* txth 10))(cadr pt3))

                ptx4 (list (+(car pt3)(* txth 5)) (-(cadr pt3)(* txth 1.0)))

       )

       (setvar "clayer" "CC2T_NEZ")

       (command "_line" pt0 pt4 "")

       (metxt ptx1 5 txth 0 "SYMBOL")

       (metxt ptx2 5 txth 0 "NORTH")

       (metxt ptx3 5 txth 0 "EAST")

       (metxt ptx4 5 txth 0 "ELEVATIONS")

       (setq pt0b  (list (car pt0)(-(cadr pt0)(* txth 2.0)))

                pt1b  (list (car pt1)(-(cadr pt1)(* txth 2.0)))

                pt2b  (list (car pt2)(-(cadr pt2)(* txth 2.0)))

                pt3b  (list (car pt3)(-(cadr pt3)(* txth 2.0)))

                pt4b  (list (car pt4)(-(cadr pt4)(* txth 2.0)))

       )

       (command "_line" pt0b pt4b "")

       (repeat nump

              (setq ptx1 (list (car ptx1) (-(cadr ptx1)(* txth 2.0)))

                       ptx2 (list (car ptx2) (-(cadr ptx2)(* txth 2.0)))

                       ptx3 (list (car ptx3) (-(cadr ptx3)(* txth 2.0)))

                       ptx4 (list (car ptx4) (-(cadr ptx4)(* txth 2.0)))

              )

              (metxt ptx1 5 txth 0 (nth 0 (nth num lst)))

              (metxt ptx2 5 txth 0 (rtos (nth 2 (nth num lst))2 dec))

              (metxt ptx3 5 txth 0 (rtos (nth 1 (nth num lst))2 dec))

              (metxt ptx4 5 txth 0 (rtos (nth 3 (nth num lst))2 dec))

              (setq pt0b  (list (car pt0b)(-(cadr pt0b)(* txth 2.0)))

                       pt1b  (list (car pt1b)(-(cadr pt1b)(* txth 2.0)))

                       pt2b  (list (car pt2b)(-(cadr pt2b)(* txth 2.0)))

                       pt3b  (list (car pt3b)(-(cadr pt3b)(* txth 2.0)))

                       pt4b  (list (car pt4b)(-(cadr pt4b)(* txth 2.0)))

              )

              (command "_line" pt0b pt4b "")

              (setq num (1+ num))

       );repeat

       (command "_line" pt0 pt0b "")

       (command "_line" pt1 pt1b "")

       (command "_line" pt2 pt2b "")

       (command "_line" pt3 pt3b "")

       (command "_line" pt4 pt4b "")

(princ)      

(setvar "osmode" old_osnap) ; old_osnap

(setvar "clayer" old_layer) ; old_layer

(princ)

)


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

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