;|---------------------------------------------------------------------------|
|  Seçim seti ile belirlenen bir obje gurubu içinde, belirlenen bir         |
|  Layer'daki Point veya Circle objelerinin koordinatlarını, objelerin      |
|  yerleşimine göre, satır, sütun veya oluşturulma sırasına göre            |
|  numaralandırıp X, Y ve Z koordinatlarını tablo halinde yazar.            |
|  İstenirse Nokta Nuamaraları ve koordinatlar -.xls uzantılı dosyaya da    |
|  yazdırılır. Tablodaki nokta numaraları noktanın yanındaki numaraya field |
|  ile bağlanır. X, Y ve Z koordinat değerleri ilgili Point veya Circle     |
|  objesine field ile bağlanırlar. Nokta numaraları ve noktaların konumları |
|  değiştirildiğinde, ilk regen işleminde Tablodaki değerler güncellenirler.|
|  Hazırlayan: M. Şahin Güvercin  25/02/2012  www.autocadokulu.com          |
|___________________________________________________________________________|;
(defun dcLcrT (dcLfL / sTr f)
  (setq f (open dcLfL "w")) (foreach sTr
'("//-------------------=={ PcT.dcl Dialog Definition }==-------------------//"
  "//              Author: M. Sahin Guvercin, Copyright © 2012              //"
  "//                        www.autocadokulu.com                           //"
  "//-----------------------------------------------------------------------//"
  "PcT:dialog {"
  "label=\"**** Point Coordinate Table ****\"; width=15;"
  ": boxed_row {"
  "  : toggle {label=\" Koordinat Tablosu Dosyaya Yazılsın\"; key=\"Dsy\";}}"
  ": boxed_radio_row {label=\"Nokta Objelerinin Türü\";"
  "  : radio_button {label=\"Point\"; key=\"PnT\";}"
  "  : radio_button {label=\"Circle\"; key=\"CrC\";}}"
  ": boxed_row {"
  "  : popup_list {label=\"Noktaların bulunduğu Layer:\";"
  "    edit_width=12; key=\"Lyr\";}}"
  ": boxed_radio_row {label=\"Nokta Numarası Yerleşimi\";"
  "  : radio_button {label=\"Ortala\"; key=\"Ort\";}"
  "  : radio_button {label=\"Alarga\"; key=\"ALr\";}}"
  ": boxed_radio_row {label=\"Nokta Numaralama Düzeni\"; key=\"Mtr\";"
  "  : radio_button {label=\"Sırasız\"; key=\"N\";}"
  "  : radio_button {label=\"Satır\"; key=\"S\";}"
  "  : radio_button {label=\"Sütun\"; key=\"K\";}}"
  ": edit_box{label=\"Başlangıç Nokta Numarası:\";"
  "  key=\"Pno\"; width=1; edit_width=8;}"
  ": edit_box{label=\"    Ondalık Basamak Sayısı:\";"
  "  key=\"dpL\"; width=1; edit_width=8;}"
  ": edit_box{label=\"                 Yazı Yüksekliği:\";"
  "  key=\"Yyu\"; width=1; edit_width=8;} spacer;"
  ": boxed_row {: text {key=\"CpR\"; value="
  "\"Hazırlayan:M.Şahin Güvercin-www.autocadokulu.com\";}}"
  "ok_cancel;}")
    (write-line sTr f))
  (close f))
;|___________________________________________________________________________|;
(defun c:PcT (/ *error* d_id Lyr Ly w_n kuk nn nmr PtOb n nks tks dLset mVset
              ac msf nksX nksY pts XLer YLer L PvT PvT0 StnS StrS m Mtrx K nnum
              X Y Z gnok onk nnk)
  (command "_.undo" "group") (setq ecm (getvar "cmdecho"))
  (setvar "cmdecho" 0) (vl-load-com)
  (defun *error* (msg) (setvar "dimzin" edz) (princ msg) (setvar "cmdecho" ecm)
    (command "undo" "e") (setq *error* nil) (prin1))
  (setq edz (getvar "dimzin"))  (setvar "dimzin" 0)
  (if (not fsv) (setq fsv "Hayir")) (if (not ObT) (setq ObT "Point"))
  (if (not Lay) (setq Lay "0"))     (if (not ALor) (setq ALor "Ortala"))
  (if (not srk) (setq srk "No"))    (if (not num) (setq num "P1"))
  (if (not dpL) (setq dpL 2))
  (if (not TxH) (setq TxH (* (getvar "dimtxt") (getvar "dimscale"))))
  (setq PcTdLg (strcat (substr (findfile "acad.exe") 1 (- (strlen (findfile
                                         "acad.exe")) 8)) "Support\\PcT.dcL"))
  (if (not (findfile PcTdLg)) (dcLcrT PcTdLg))
  (if (< (setq d_id (load_dialog PcTdLg)) 0) (exit))
  (setq Lyr (list (cdr (assoc 2 (tblnext  "Layer" T)))))
  (while (setq Ly (tblnext "Layer"))
    (setq Lyr (append Lyr (list (cdr (assoc 2 Ly)))))) (setq w_n -1)
  (while (< w_n 2)
    (if (not (new_dialog "PcT" d_id)) (exit))
    (if (= fsv "Evet") (set_tile "Dsy" "1") (set_tile "Dsy" "0"))
    (if (= ObT "Point") (set_tile "PnT" "1") (set_tile "CrC" "1"))
    (start_list "Lyr") (if (> (length Lyr) 1)
      (mapcar '(lambda (p) (add_list p)) Lyr) (add_list (nth 0 Lyr)))
    (end_list) (set_tile "Lyr" (itoa (vl-position Lay Lyr)))
    (if (= ALor "Ortala") (set_tile "Ort" "1") (set_tile "ALr" "1"))
    (cond ((= srk "No") (set_tile "N" "1"))
          ((= srk "Satir") (set_tile "S" "1"))
          ((= srk "Kolon") (set_tile "K" "1"))) (set_tile "Pno" num)
    (set_tile "dpL" (itoa dpL)) (set_tile "Yyu" (rtos TxH 2 dpL))
    (action_tile "Dsy" "(if (= (get_tile \"Dsy\") \"1\")
                          (setq fsv \"Evet\") (setq fsv \"Hayir\"))")
    (action_tile "PnT" "(if (= (get_tile \"PnT\") \"1\")
                            (setq ObT \"Point\") (setq ObT \"Circle\"))")
    (action_tile "CrC" "(if (= (get_tile \"CrC\") \"1\")
                            (setq ObT \"Circle\") (setq ObT \"Point\"))")
    (action_tile "Lyr" "(setq Lay (nth (atoi (get_tile \"Lyr\")) Lyr))")
    (action_tile "Ort" "(if (= (get_tile \"Ort\") \"1\")
                          (setq ALor \"Ortala\") (setq ALor \"Alarga\"))")
    (action_tile "ALr" "(if (= (get_tile \"ALr\") \"1\")
                          (setq ALor \"Alarga\") (setq ALor \"Ortala\"))")
    (action_tile "N" "(if (= (get_tile \"N\") \"1\") (setq srk \"No\"))")
    (action_tile "S" "(if (= (get_tile \"S\") \"1\") (setq srk \"Satir\"))")
    (action_tile "K" "(if (= (get_tile \"K\") \"1\") (setq srk \"Kolon\"))")
    (action_tile "Pno" "(setq num (get_tile \"Pno\"))")
    (action_tile "dpL" "(setq dpL (atoi (get_tile \"dpL\")))")
    (action_tile "Yyu" "(setq TxH (atof (get_tile \"Yyu\")))")
    (action_tile "accept" "(done_dialog 2)")
    (action_tile "cancel" "(done_dialog 3)")
    (setq w_n (start_dialog))) (if (= w_n 3) (exit))
  (if (> (ascii (substr num 1 1)) 57)
   (setq nn (substr num 1 1) nmr (1- (atoi (substr num 2 (- (strlen num) 1)))))
   (setq nn  "" nmr (1- (atoi num))))
  (if (= fsv "Evet")
    (setq fs (open (getfiled "Koordinat Yazılacak Dosya" "" "xls" 1) "w")))
  (setq kuk (princ "\nKoordinatı yazılacak objeler seçiniz: ")
        PtOb (ssget (list (cons 0 ObT) (cons 8 Lay)))
        L   (sslength PtOb) n -1 pnts nil Mtrx nil elv  (getvar "elevation")
        nks  '((0.00 0.00) (40.00 0.00) (20.00 -1.50) (0.00 -2.00) (6.25 -2.00)
               (17.50 -2.00) (28.75 -2.00) (40.00 -2.00) (0.75 -3.50)
               (12.00 -3.50) (23.25 -3.50) (34.50 -3.50) (0.00 -4.00)
               (40.00 -4.00) (0.75 -5.50) (7.25 -5.50) (18.50 -5.50)
               (29.75 -5.50) (0.00 -6.00) (6.25 -6.00) (17.50 -6.00)
               (28.75 -6.00) (40.00 -6.00))
        nks  (mapcar '(lambda (xy) (trans (list (* (car xy) TxH)
                                         (* (cadr xy) TxH) elv) 1 0 nil)) nks)
        tks (mapcar '(lambda (pr) (trans pr 0 1 nil)) nks)
        dLset (ssadd) mVset (ssadd) ac (/ pi 2.0) msf (* 2 TxH))
  (entmake (list (cons 0 "LINE") (cons 10 (nth 0 tks)) (cons 11 (nth 1 tks))))
  (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 3 tks)) (cons 11 (nth 7 tks))))
  (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 12 tks))
                 (cons 11 (nth 13 tks)))) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 0 tks))
                 (cons 11 (polar (nth 18 tks) ac msf))))
  (ssadd (entlast) dLset) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 4 tks))
                 (cons 11 (polar (nth 19 tks) ac msf))))
  (ssadd (entlast) dLset) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 5 tks))
                 (cons 11 (polar (nth 20 tks) ac msf))))
  (ssadd (entlast) dLset) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 6 tks))
                 (cons 11 (polar (nth 21 tks) ac msf))))
  (ssadd (entlast) dLset) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "LINE") (cons 10 (nth 1 tks))
                 (cons 11 (polar (nth 22 tks) ac msf))))
  (ssadd (entlast) dLset) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 2 tks)) (cons 40 Txh)
                 (cons 1 "Koordinat Tablosu") (cons 50 0.0) (cons 72 1)
                 (cons 11 (nth 2 tks)))) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 8 tks)) (cons 40 TxH)
                 (cons 1 "Nokta") (cons 50 0.0))) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 9 tks)) (cons 40 TxH)
                 (cons 1 "x") (cons 50 0.0))) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 10 tks)) (cons 40 TxH)
                 (cons 1 "y") (cons 50 0.0))) (ssadd (entlast) mVset)
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 11 tks)) (cons 40 TxH)
                 (cons 1 "z") (cons 50 0.0))) (ssadd (entlast) mVset)
  (if (= fsv "Evet") (write-line "Nokta\tx\ty\tz" fs))
  (setq nks  (list (nth 12 tks) (nth 13 tks) (polar (nth 8 tks) 0 TxH)
               (polar (nth 9 tks) 0 (* 4 TxH)) (polar (nth 10 tks) 0 (* 4 TxH))
               (polar (nth 11 tks) 0 (* 4 TxH)))
        nksX (mapcar '(lambda (X) (car X)) nks)
        nksY (mapcar '(lambda (Y) (cadr Y)) nks))
  (while (< (setq n (1+ n)) L)
    (setq pnts (append pnts (list (cdr (assoc 10 (entget (ssname PtOb n))))))))
  (if (= srk "No") (setq Mtrx (reverse pnts)) (progn
      (setq pts  (mapcar '(lambda (xy) (list (car xy) (cadr xy))) pnts)
            XLer (mapcar '(lambda (xx) (car xx)) pts)
            YLer (mapcar '(lambda (yy) (cadr yy)) pts)
            L    (length Xler) n    -1)
      (while (< (setq n (1+ n)) L) (setq pvt0 (nth n XLer)
              pvt  (vl-remove pvt0 XLer) XLer (append (list pvt0) pvt)
              L    (length XLer))) (setq L (length YLer)  n -1)
      (while (< (setq n (1+ n)) L) (setq pvt0 (nth n YLer)
              pvt  (vl-remove pvt0 YLer) YLer (append (list pvt0) pvt)
              L    (length YLer)))
      (setq XLer (vl-sort XLer '<) YLer (vl-sort YLer '>) StnS (length XLer)
            StrS (length YLer) m -1)
      (cond ((= srk "Satir") (while (< (setq m (1+ m)) StrS) (setq n -1)
           (while (< (setq n (1+ n)) StnS) (setq Mtrx (append Mtrx
                            (list (list (nth n XLer) (nth m YLer))))))))
            ((= srk "Kolon") (while (< (setq m (1+ m)) StnS) (setq n -1)
             (while (< (setq n (1+ n)) StrS) (setq Mtrx (append Mtrx
                            (list (list (nth m XLer) (nth n YLer)))))))))
      (setq L (length Mtrx) n -1)
      (while (< (setq n (1+ n)) L) (if (= (vl-position (nth n Mtrx) pts) nil)
         (setq Mtrx (vl-remove (nth n Mtrx) Mtrx) L (length Mtrx) n (1- n))))))
  (setq K (length Mtrx) L (length pnts) m -1)
  (while (< (setq m (1+ m)) K) (setq n -1)
    (while (< (setq n (1+ n)) L)
      (if (and (= (car (nth m Mtrx)) (cadr (assoc 10 (entget(ssname PtOb n)))))
            (= (cadr (nth m Mtrx)) (caddr (assoc 10 (entget(ssname PtOb n))))))
        (progn (setq nksY (mapcar '(lambda (Y) (- Y msf)) nksY)
                     nks  (mapcar '(lambda (X Y) (list X Y)) nksX nksY)
                     nnum (strcat nn (itoa (setq nmr (1+ nmr))))
                     X    (car (nth m Mtrx)) Y (cadr (nth m Mtrx))
                     Z    (cadddr (assoc 10 (entget (ssname PtOb n))))
                     gnok (trans (list x y z) 0 1 nil)
                      X (car gnok) Y (cadr gnok) Z (caddr gnok) p -1)
          (entmake (list (cons 0 "LINE") (cons 10 (nth 0 nks))
                         (cons 11 (nth 1 nks)))) (ssadd (entlast) mVset)
          (if (= aLoR "Alarga")
            (entmake (list (cons 0 "TEXT") (cons 40 TxH) (cons 1 nnum)
                         (cons 10 (trans (list (+ X TxH) (+ Y Txh) Z) 1 0 nil))
                         (cons 50 0.0)))
            (entmake (list (cons 0 "TEXT") (cons 40 TxH) (cons 1 nnum)
                           (cons 10 (setq kuk (trans (list X Y Z) 1 0 nil)))
                           (cons 50 0.0) (cons 72 4) (cons 11 kuk))))
          (entmake (list (cons 0 "TEXT") (cons 10 (nth 2 nks)) (cons 40 TxH)
                         (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                   (itoa (vla-get-ObjectID (vlax-ename->vla-object (entlast))))
                                         ">%).TextString>%"))
                         (cons 50 0.0))) (ssadd (entlast) mVset)
          (if (= ObT "Point") (setq cRd "Coordinates") (setq cRd "Center"))
          (entmake (list (cons 0 "TEXT") (cons 10 (nth 3 nks)) (cons 40 TxH)
                         (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                    (setq ObjId (itoa (vla-get-ObjectID (vlax-ename->vla-object
                    (ssname (ssget "x" (list (cons 0 ObT) (cons 8 Lay)
                                    (cons 10 (trans (list X Y Z) 1 0)))) 0)))))
                          ">%)." cRd " \\f %lu2%pt1%pr" (itoa dpL) ">%"))
                         (cons 11 (nth 3 nks)) (cons 50 0.0) (cons 72 2)))
          (ssadd (entlast) mVset)
          (entmake (list (cons 0 "TEXT") (cons 10 (nth 4 nks)) (cons 40 TxH)
                         (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                        ObjId ">%)." cRd " \\f %lu2%pt2%pr" (itoa dpL) ">%"))
                         (cons 11 (nth 4 nks)) (cons 50 0.0) (cons 72 2)))
          (ssadd (entlast) mVset)
          (entmake (list (cons 0 "TEXT") (cons 10 (nth 5 nks)) (cons 40 TxH)
                         (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                        ObjId ">%)." cRd " \\f %lu2%pt4%pr" (itoa dpL) ">%"))
                         (cons 11 (nth 5 nks)) (cons 50 0.0) (cons 72 2)))
          (ssadd (entlast) mVset)
          (if (= fsv "Evet")
            (write-line (strcat nnum "\t" (rtos X 2 dpL) "\t" (rtos Y 2 dpL)
                                "\t" (rtos Z 2 dpL)) fs))
          (while (< (setq p (1+ p)) 5)
            (setq pvt (entget (ssname dLset p))
                  pvt (subst (cons 11 (list (cadr (assoc 11 pvt))
                       (- (caddr (assoc 11 pvt)) msf) (cadddr (assoc 11 pvt))))
                             (assoc 11 pvt) pvt))
            (entmod pvt) (entupd (cdr (assoc -1 pvt))))))))
  (setq onK (list 0.0 0.0 0.0) L (sslength mVset)) (command "_.regen")
  (while (/= 3 (car (setq nnK (grread T 4 0))))
    (setq nnK (trans (cadr nnK) 1 0 nil) n -1)
    (while (< (setq n (1+ n)) L)
      (vla-transformby (vlax-ename->vla-object (ssname mVset n)) (vlax-tmatrix
          (list (list 1 0 0 (- (car nnK) (car onK)))
            (list 0 1 0 (- (cadr nnK) (cadr onK)))
            (list 0 0 1 (- (caddr nnK) (caddr onK))) (list 0 0 0 1)))))
    (setq onK nnK)) (if fs (close fs))
  (setq num (strcat nn (itoa (setq nmr (1+ nmr)))))
  (setvar "cmdecho" ecm) (setvar "dimzin" edz) (command "_.undo" "e") (prin1))
;|___________________________________________________________________________|;
(write-line "Hazırlayan: M. Şahin Güvercin - www.autocadokulu.com") (prin1)
;|___________________________________________________________________________|;