* E Posta Adresiniz:
* Kodu Girin:

İleti Yazar
19.11.2016 14:30
84211    
heisenberg33

[2] Girişimci

Online Durumu

4 ileti
Topoğraf
mersin

Hocam sectigimiz line,polyline,point'in Z degerini verecek lispe cok ihtiyac duyuyorum. Eger varsa paylasabilir misiniz?

09.05.2018 10:43
86307    
folderdash

[2] Girişimci

Online Durumu

1 ileti
harita mühendisi
istanbul

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.



Hocam selamlar

Öncelikle emeğinize sağlık.Sorum şu enkesitlerde düşey ölçek normalden 5 kat küçük.

Yani yatayda gerçekte 1 birim olan çizgi 1 birim çizilirken, düşeyde ise gerçekte 1 birim olan çizgi 5 birim olarak çiziliyor. Yazdığınız bu lispi bu yönde nasıl düzenleyebiliriz?

Teşekkürler

Teşekkürler

15.08.2018 21:57
86565    
cnrtkdmr

[2] Girişimci

Online Durumu

2 ileti

elazığ

Hocam merhabalar yıllar önce yazdığınız ve bugün hala kullandığımız Kome lispi için öncelikle teşekkür ederim.
Ancak bir soru sormak istiyorum izninizle.
Lispi çalıştırdıktan sonra eksen çizgisini göstermemizi ve referans kot değerini girmemizi istiyor.Referans kot yazısını yazarak değilde üzerine tıklayarak okutamaz mıyız?
Yada daha güzeli ama bence daha zoru; bizden kindex tabakasını sorsa ve onu gösterdiğimizde içerisindeki eksen çizgisini info_cer tabakasından, kotuda kıyas tabakasından okuyup bizden sadece yeni nokta göstermemizi istese olmaz mı?
Yazılım bilgim olmadığı için rahatça istiyorum kusura bakılmasın lütfen.
Saygılarımla.

15.08.2018 21:59
86566    
cnrtkdmr

[2] Girişimci

Online Durumu

2 ileti

elazığ

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...

Copyright © 2004-2018 | Tüm Hakları Saklıdır | 1951 | Site haritası | İstatistikler | Hakkımızda | Kadromuz | Gizlilik | Reklam