;|---------------------------------------------------------------------------|
|  Sırasıyla seçilen noktaların koordinatlarını, belirlenen numaradan       |
|  başlayarak numaralandırıp, Nokta Numaraları ve Koordinatlarını tablo     |
|  halinde yazar. Tablodaki Nokta Numaraları, X, Y ve Z koordinat değerleri |
|  nokta numarası yazısına 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  02/04/2012  www.autocadokulu.com     |
|___________________________________________________________________________|;
(write-line "Hazırlayan: M. Şahin Güvercin - www.autocadokulu.com")
;|___________________________________________________________________________|;
(defun c:PcT2 (/ *error* TxH dpL NuM NkS aC MsF PvT DoB n p0 p1 ObjID)
  (setq ocm (getvar "cmdecho")) (setvar "cmdecho" 0) (command "_.undo" "group")
  (defun *error* (msg) (setvar "dimzin" odz) (princ msg) (command "undo" "e")
   (setvar "cmdecho" ocm) (setq oNuM NuM) (prin1)) (vl-load-com)
  (setq odz (getvar "dimzin")) (setvar "dimzin" 0)
  (if (not oTxH) (setq oTxH (* (getvar "dimtxt") (getvar "dimscale"))))
  (if (not odpL) (setq odpL 2)) (if (not oNuM) (setq oNuM 1))
  (setq TxH (getreal (strcat "\n         Yazı yüksekliği <" (rtos oTxH) ">:"))
        dpL (getint (strcat "\n  Ondalık basamak sayısı <" (itoa odpL) ">:"))
        NuM (getint (strcat "\nBaşlangıç Nokta Numarası <" (itoa oNuM) ">:")))
  (if TxH(setq oTxH TxH)(setq TxH oTxH))(if dpL(setq odpL dpL)(setq dpL odpL))
  (if NuM (setq NuM (1- NuM)) (setq NuM (1- oNuM)))
  (setq NkS '((0.0 0.0 0.0) (40.0 0.0 0.0) (40.0 -4.0 0.0) (0.0 -4.00 0.0)
              (0.0 -2.0 0.0) (40.0 -2.0 0.0) (6.25 -2.0 0.0) (6.25 -4.0 0.0)
              (17.5 -2.0 0.0) (17.5 -4.0 0.0) (28.75 -2.0 0.0) (28.75 -4.0 0.0)
              (20.0 -1.5 0.0) (0.75 -3.5 0.0) (12.0 -3.5 0.0) (23.25 -3.5 0.0)
              (34.5 -3.5 0.0) (4.0 -3.5 0.0) (15.5 -3.5 0.0) (26.75 -3.5 0.0)
              (38.0 -3.5 0.0) (20.0 -2.0 0.0)) aC (* pi 1.5) MsF (* 2 TxH)
        PvT (entlast) DoB (ssadd) n 10)
  (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 67 0)
        (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 1) (cons 43 0.0)
        (cons 38 0.0)(cons 39 0.0) (cons 10 (nth 0 NkS)) (cons 10 (nth 1 NkS))
        (cons 10 (nth 2 NkS)) (cons 10 (nth 3 NkS))))
  (entmake (list (cons 0 "LINE") (cons 10 (nth 4 NkS)) (cons 11 (nth 5 NkS))))
  (entmake (list (cons 0 "LINE") (cons 10 (nth 6 NkS)) (cons 11 (nth 7 NkS))))
  (entmake (list (cons 0 "LINE") (cons 10 (nth 8 NkS)) (cons 11 (nth 9 NkS))))
  (entmake (list '(0 . "LINE") (cons 10 (nth 10 NkS)) (cons 11 (nth 11 NkS))))
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 12 NkS)) (cons 40 1.0)
      '(1 . "Koordinat Tablosu") '(50 . 0.0) '(72 . 1)(cons 11 (nth 12 NkS))))
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 13 NkS)) (cons 40 1.0)
                 (cons 1 "Nokta") (cons 50 0.0)))
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 14 NkS)) (cons 40 1.0)
                 (cons 1 "x") (cons 50 0.0)))
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 15 NkS)) (cons 40 1.0)
                 (cons 1 "y") (cons 50 0.0)))
  (entmake (list (cons 0 "TEXT") (cons 10 (nth 16 NkS)) (cons 40 1.0)
                 (cons 1 "z") (cons 50 0.0)))
  (while (setq PvT (if PvT (entnext PvT)(entnext)))(ssadd PvT DoB))
  (while (not (minusp (setq n (1- n))))
    (setq PvT (vlax-ename->vla-object (ssname DoB n)))
    (vla-transformby PvT (vlax-tmatrix (list (list TxH 0 0 0) (list 0 TxH 0 0)
                 (list 0 0 TxH 0) (list 0 0 0 1)))))
  (setq NkS (mapcar '(lambda (pr) (list (* (car pr) TxH) (* (cadr pr) TxH)
                                  (getvar "elevation"))) NkS) p0 (nth 21 NkS))
  (while (/= 3 (car (setq p1 (grread T 4 0)))) (setq p1 (cadr p1) n 10)
    (while (not (minusp (setq n (1- n))))
      (setq PvT (vlax-ename->vla-object (ssname DoB n)))
      (vla-transformby PvT (vlax-tmatrix (list
       (list 1 0 0 (- (car p1) (car p0))) (list 0 1 0 (- (cadr p1) (cadr p0)))
       (list 0 0 1 (- (caddr p1) (caddr p0))) (list 0 0 0 1))))) (setq p0 p1))
  (setq NkS (mapcar '(lambda (pr) (list (- (+ (car pr) (car p0)) (* 20.0 TxH))
         (+ (cadr pr) (cadr p0) (* 2.0 TxH)) (+ (caddr pr) (caddr p0)))) NkS))
  (while (setq NkT (getpoint "\r    Nokta Seçiniz: "))
    (entmake (list (cons 0 "LINE")(cons 10 (nth 3 NkS))(cons 11 (nth 2 NkS))))
    (setq ObjID (itoa (vla-get-ObjectID (vlax-ename->vla-object (entlast))))
          PvT (entget (ssname DoB 0))
     PvT (subst(cons 10(list(car(setq p1(polar(nth 3 NkS) aC MsF)))(cadr p1)))
                (cons 10 (list (car (nth 3 NkS)) (cadr (nth 3 NkS)))) PvT)
     PvT (subst(cons 10(list(car(setq p1(polar(nth 2 NkS) aC MsF)))(cadr p1)))
                    (cons 10 (list (car (nth 2 NkS)) (cadr (nth 2 NkS)))) PvT)
   PvT (entmod PvT) PvT (entupd(cdr(assoc -1 PvT))) PvT (entget(ssname DoB 2))
          PvT (subst (cons 11 (polar (nth 7 NkS) aC MsF)) (assoc 11 PvT) PvT)
   PvT (entmod PvT) PvT (entupd(cdr(assoc -1 PvT))) PvT (entget(ssname DoB 3))
          PvT (subst (cons 11 (polar (nth 9 NkS) aC MsF)) (assoc 11 PvT) PvT)
   PvT (entmod PvT) PvT (entupd(cdr(assoc -1 PvT))) PvT (entget(ssname DoB 4))
          PvT (subst (cons 11 (polar (nth 11 NkS) aC MsF)) (assoc 11 PvT) PvT)
          PvT (entmod PvT) PvT (entupd (cdr (assoc -1 PvT)))
   NkS (mapcar '(lambda (pr) (list (car pr)(- (cadr pr) MsF)(caddr pr))) NkS))
   (entmake(list(cons 0 "TEXT")(cons 40 TxH)(cons 1 (itoa(setq NuM (1+ NuM))))
                   (cons 10 NkT) (cons 50 0.0)))
    (entmake (list (cons 0 "TEXT") (cons 10 (nth 17 NkS)) (cons 40 TxH)
                   (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
     (setq ObjID (itoa (vla-get-ObjectID (vlax-ename->vla-object (entlast)))))
       ">%).TextString>%")) (cons 11 (nth 17 nks)) (cons 50 0.0) (cons 72 2)))
    (entmake (list (cons 0 "TEXT") (cons 10 (nth 18 nks)) (cons 40 TxH)
                   (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId " ObjID
                      ">%).InsertionPoint \\f \"%lu2%pt1%pr" (itoa dpL) ">%"))
                   (cons 11 (nth 18 nks)) (cons 50 0.0) (cons 72 2)))
    (entmake (list (cons 0 "TEXT") (cons 10 (nth 19 nks)) (cons 40 TxH)
                   (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId " ObjId
                      ">%).InsertionPoint \\f \"%lu2%pt2%pr" (itoa dpL) ">%"))
                   (cons 11 (nth 19 nks)) (cons 50 0.0) (cons 72 2)))
    (entmake (list (cons 0 "TEXT") (cons 10 (nth 20 nks)) (cons 40 TxH)
                   (cons 1 (strcat "%<\\AcObjProp Object(%<\\_ObjId " ObjId
                      ">%).InsertionPoint \\f \"%lu2%pt4%pr" (itoa dpL) ">%"))
        (cons 11 (nth 20 nks)) (cons 50 0.0) (cons 72 2))) (command "_.Regen"))
  (setvar "dimzin" odz) (setq oNuM (1+ NuM)) (command "undo" "e")
  (setvar "cmdecho" ocm) (prin1))
;|___________________________________________________________________________|;

;;;=========================================================================;;;
;;;     CLP.LSP                                                             ;;;
;;;     Secilen dogrunun her iki ucundan belirlenen miktar kadar kirpar,    ;;;
;;;     kirpma miktari negatif olabilir, bu durumda dogru belirlenen        ;;;
;;;     miktar kadar her iki ucundan uzatilir                               ;;;
;;;     Hazırlayan M.S.Güvercin                                             ;;;
;;;=========================================================================;;;
(defun C:CLP (/ km e n1 n2 aci)
   (setvar "cmdecho" 0)  (command "undo" "group") (if (= ekm nil) (setq ekm 5))
   (if (not (setq km (getreal (strcat "\nKirpma miktari <" (rtos ekm) ">:"))))
     (setq km ekm)) (setq e (car (entsel "\nKirpilacak dogruyu seciniz...")))
   (while e (setq e (entget e) n1 (cdr (assoc 10 e)) n2 (cdr (assoc 11 e))
                  aci (angle n1 n2)
                  n1 (polar n1 aci km) n2 (polar n2 (+ pi aci) km)
                  e (subst (cons 10 n1) (assoc 10 e) e)
                  e (subst (cons 11 n2) (assoc 11 e) e)
                  e (entmod e) e (entupd (cdr (assoc -1 e)))
                  e (car (entsel "\rYeni dogru seciniz..."))))
   (setq ekm km) (command "undo" "e")  (prin1)
)