Alıntı

---

ProhibiT :
Merhaba arkadaşlar.

Bundan 6 yıl önce burada paylaştığım Lisp program. O zamanın şartlarına göre, arkadaşlarımızın istekleri doğrultusunda yazılmıştı. Zaman içinde gelen isteklerin tümünü karşılayacak şekilde yeniden düzenleyip paylaşıyorum.

Kod:

;|---------------------------------------------------------------------------|
| Bu Program M.Ş. Güvercin tarafından                                       |
| Mehmet Yangın için Hazırlanmıştır. 08.12.2009 22:10                       |
| Bu konu başlığı altında gelen isteklere göre Düzenlendi...                |
|           ProhibiT www.cizimokulu.com 28.08.2015  14:15                   |
|---------------------------------------------------------------------------|;
(defun c:KoMe (/ dgrl eksen kot kotor msf mesor n1 n2 n3 n4 nokta nokx noky
               onbs otsz refko tsz)
  (defun tRL  (dgr ob / frk) (if (not (vl-string-search "." dgr))
      (setq dgr (strcat dgr ".") frk ob)
      (setq frk (- ob (- (strlen dgr) (1+ (vl-string-search "." dgr))))))
    (if (> frk 0) (repeat frk (setq dgr (strcat dgr "0"))) (setq dgr dgr)))
  (command "undo" "group") (setvar "cmdecho" 0)
  (if (not tsz) (setq tsz (getvar "textsize"))) (if (not (setq otsz tsz tsz
(getreal (strcat "\nYazı Yüksekliği <" (rtos tsz 2) ">: ")))) (setq tsz otsz))
  (if (not onbs) (setq onbs (getvar "Luprec")))
  (if (not (setq oonb onbs onbs (getint
(strcat "\nOndalik Basamak Sayısı <" (itoa onbs) ">: ")))) (setq onbs oonb))
  (while (/= "LINE" (cdr (assoc 0 (entget
                (setq eksen (car (entsel "\nEksen Çizgisini Seçiniz..."))))))))
  (setq mesor (cadr (assoc 10 (entget eksen)))
        kotor (cadr (getpoint "\nReferans Kot Noktasını Seçiniz..."))
        refko (getreal "\nReferans Kot Değerini Giriniz: "))
  (while (setq nokta (getpoint "\Yeni Nokta Seçiniz..."))
    (setq nokx (car nokta) noky (cadr nokta) msf (rtos (- nokx mesor) 2 onbs)
          kot  (rtos (+ refko (- noky kotor)) 2 onbs)
          dgrl (getpoint nokta "\nYazıların yerini seçiniz..."))
    (setq msf (tRL msf onbs) kot  (tRL kot onbs))
    (if (zerop (atof kot)) (setq kot (strcat "%%p" kot))
      (if (> (atof kot) 0) (setq kot (strcat "+" kot))))
      (if (> (atof msf) 0) (setq msf (strcat "+" msf)))
    (if (> (cadr dgrl) noky)
      (setq n1 (polar nokta (* pi 0.25) (* tsz 0.707106781))
            n2 (polar nokta (* pi 0.75) (* tsz 0.707106781))
            n3 (polar nokta (* pi 0.50) (* tsz 1.00))
            n4 (polar nokta (* pi 0.50) (* tsz 2.50)))
      (setq n1 (polar nokta (* pi 1.25) (* tsz 0.707106781))
            n2 (polar nokta (* pi 1.75) (* tsz 0.707106781))
            n3 (polar nokta (* pi 1.50) (* tsz 2.00))
            n4 (polar nokta (* pi 1.50) (* tsz 2.50))))
    (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(67 . 0)
      '(100 . "AcDbPolyline") '(90 . 3) '(70 . 1) '(62 . 1) (cons 10 nokta)
       (cons 10 n1) (cons 10 n2)))
    (entmake (list (cons 0 "TEXT") (cons 10 n3) (cons 1 kot) (cons 40 tsz)
       (cons 72 1) (cons 73 0) (cons 50 0) (cons 73 0) (cons 11 n3)))
    (if (> (cadr dgrl) noky)
      (entmake (list (cons 0 "TEXT") (cons 10 n4) (cons 1 msf) (cons 40 tsz)
        (cons 62 1) (cons 50 (/ pi 2.0)) (cons 72 0) (cons 73 2) (cons 11 n4)))
      (entmake (list (cons 0 "TEXT") (cons 10 n4) (cons 1 msf) (cons 40 tsz)
      (cons 62 1) (cons 50 (/ pi 2.0)) (cons 72 2) (cons 73 2) (cons 11 n4)))))
  (command "undo" "e") (prin1))

Herkese kolay gelsin.

---

Alıntı

---

ProhibiT :
Merhaba mehmetyangın :)

Gönderdiğin -.bmp dosyası ve verdiğin bilgiler doğrultusunda aşağıdaki lispi yazdım.
Belki başkalarının da işine yarar düşüncesiyle burada paylaşmak istiyorum.

Kod:

;;; Bu Program M.Ş. Güvercin tarafından
;;; Mehmet Yangın için Hazırlanmıştır. 
;;; 08.12.2009 22:10                   
(defun c:KoMe ()
  (command "undo" "group")
  (setvar "cmdecho" 0)
  (setq oosm  (getvar "osmode")
        ts    (getvar "textsize")
        eksen (car (entsel "\nEksen Çizgisini Seçiniz..."))
  )
  (while (/= "LINE" (cdr (assoc 0 (entget eksen))))
    (setq eksen (car (entsel "\nEksen Çizgisini Seçiniz...")))
  )
  (setq mesor (cadr (assoc 10 (entget eksen)))
        kotor (cadr (getpoint "\nReferans Kot Noktasını Seçiniz..."))
        refko (getreal "\nReferans Kot Değerini Giriniz: ")
        nokta (getpoint "\Yeni Nokta Seçiniz...")
  )
  (while nokta
    (setq nokx     (car nokta)
          noky     (cadr nokta)
          mesa     (rtos (abs (- mesor nokx)) 2 3)
          kot      (rtos (+ refko (- noky kotor)) 2 3)
          dogrultu (getpoint "\nYazıların yerini seçiniz...")
    )
    (if (= (atof kot) 0) (setq kot (strcat "%%p" kot)))
    (setq uz (strlen kot) sr 1)
    (while (and (< sr uz) (/= (substr kot sr 1) ".")) (setq sr (1+ sr)))
    (setq yer (- uz sr) frk (- 3 yer))
    (if (= yer 0) (setq kot (strcat kot ".")))
    (while (> frk 0) (setq kot (strcat kot "0") frk (1- frk)))
    (setq uz (strlen mesa) sr 1)
    (while (and (< sr uz) (/= (substr mesa sr 1) ".")) (setq sr (1+ sr)))
    (setq yer (- uz sr) frk (- 3 yer))
    (if (= yer 0) (setq mesa (strcat mesa ".")))
    (while (> frk 0) (setq mesa (strcat mesa "0") frk  (1- frk)))
    (if (> (cadr dogrultu) noky)
      (setq n1 (polar nokta (* pi 0.25) ts)
            n2 (polar nokta (* pi 0.75) ts)
            n3 (polar nokta (* pi 0.50) (* 1.00 ts))
            n4 (polar nokta (* pi 0.50) (* 2.50 ts))
      )
      (setq n1 (polar nokta (* pi 1.25) ts)
            n2 (polar nokta (* pi 1.75) ts)
            n3 (polar nokta (* pi 1.50) (* 2.00 ts))
            n4 (polar nokta (* pi 1.50) (* 2.50 ts))
      )
    )
    (setvar "osmode" 0)
    (command "pline" nokta n1 n2 "c")
    (command "change" "l" "" "p" "c" "1" "")
    (command "text" "c" n3 ts 0 kot)
    (if (> (cadr dogrultu) noky)
      (command "text" "ml" n4 ts 90 mesa)
      (command "text" "mr" n4 ts 90 mesa)
    )
    (command "change" "l" "" "p" "c" "1" "")
    (setvar "osmode" oosm)
    (setq nokta (getpoint "\Yeni Nokta Seçiniz..."))
  )
  (command "undo" "e")
  (prin1)
)

Selamlar, Sevgiler, Herkese Kolay Gelsin...

---