04.02.2011 07:13    

lazymelisa
Merhaba arkadaşlar ben ataşman hazırlarken sayıları tek tek toplayarak çk zaman kaybediyorum ¢ 0. 75 + ¢ 0. 23 gibi işlemleri yapabilecek bi lisp arıyorum yeniyim sitede tam olarak bunu bulamadım yardımcı olursanız sevinirim. . .

04.02.2011 07:26    

miyatu
Daha detaylı bilgi verirseniz yardımcı olmaya calısırım.

mesajınızdan anladıgım bu inş. işinize yarar. . .

Kod:

;calıstırma kodunu tpl olarak belirledik
(defun c:tpl ()
;td değişkeninin değerinin sıfır yapılması
  (setq td 0)
;entsel fonksiyonu ile toplanacak sayının sectirilmesi ve ts degişkenine atanması
  (setq ts (entsel "\ntoplanacak sayıyı seçiniz:"))
;while dongusu baslangıcı sart ts degişkeni nil oluncaya kadar
  (while (/= ts nil)
;secilen text in okunması
    (setq tsd (cdr (assoc 1 (entget (car ts)))))
;sayı kısmının ayrıştırılması
    (setq ty (atof (substr tsd 2)))
;toplama işleminin yapılması
    (setq td (+ td ty))
;diğer text in sectirilmesi
    (setq ts (entsel "\ntoplanacak diger sayıyı seçiniz:"))
;while dongusunden cıkıs
  )
;sonucun kullanıcıya gösterilmesi
  (alert (strcat "toplam =" (rtos td 2 2)))
)


kolay gelsin. . .

miyatu (04.02.2011 08:26 GMT)

04.02.2011 08:47    

emasi
Bu prohibit hocanin lispi. çarpılacak sayılar için yazılmışdı bir az düzen yaptım.
umarım prohibit hocamız izin verir:blush
Kod:

(defun c:topla ()
  (princ "\n  toplanacak sayilari seciniz.    .    .    ")
  (setq crpn (ssget (list (cons 0 "*text")))
        l (sslength crpn) n -1 rslt 1)
  (while (< (setq n (1+ n)) l)
    (setq rslt (+ rslt (atof (cdr (assoc 1 (entget (ssname crpn n))))))))
  (setq crpm (entget (car (entsel "\n    netice seciniz.    .    .    ")))
        crpm (subst (cons 1 (rtos rslt)) (assoc 1 crpm) crpm))
  (entmod crpm)
  (entupd (cdr (assoc -1 crpm)))
  (prin1)
)


ama rakamların önünde işaretler olursa alqılamaz. rakamlardan sonra işaret olarsa alqılar
uğurlar

04.02.2011 09:02    

ProhibiT
Izin almanıza falan gerek yok emasi :) sizlerin bu tür fonksiyonları değiştirip geliştirmenizden ancak keyif duyarım. burada bir şeyi düzeltmek lazım, işlem çarpma olduğu için, rslt değişkenine başlangıç geğeri olarak 1 vermiştim. toplama olunca, sonucu 1 fazla hesaplayacak ve yanlışa sebep olacaktır. bunun için
Kod:

(defun c:tplm ()
  (princ "\n  toplanacak sayıları seciniz  ")
  (setq tpln (ssget (list (cons 0 "*text")))
        l (sslength crpn) n -1 rslt nil)
  (while (< (setq n (1+ n)) l)
    (if rslt (setq rslt (+ rslt (atof (cdr (assoc 1 (entget (ssname tpln n)))))))
      (setq rslt (atof (cdr (assoc 1 (entget (ssname tpln n))))))))
  (setq tplm (entget (car (entsel "\n    netice seciniz")))
        tplm (subst (cons 1 (rtos rslt)) (assoc 1 tplm) tplm))
  (entmod tplm)
  (entupd (cdr (assoc -1 tplm)))
  (prin1)
)
şeklinde kullanırsanız bu hatayı ortadan kaldırmış olursunuz.
her ne kadar çarpma işleminde hataya sebep olmuyorsa bile, çarpım yapan fonksiyon kodunu da;
Kod:

(defun c:crpm ()
  (princ "\n  çarpılacak sayıları seçiniz ")
  (setq crpn (ssget (list (cons 0 "*text")))
        l (sslength crpn) n -1 rslt nil)
  (while (< (setq n (1+ n)) l)
    (if rslt (setq rslt (* rslt (atof (cdr (assoc 1 (entget (ssname crpn n)))))))
      (setq rslt (atof (cdr (assoc 1 (entget (ssname crpn n))))))))
  (setq crpm (entget (car (entsel "\n    çarpımı seçiniz ")))
        crpm (subst (cons 1 (rtos rslt)) (assoc 1 crpm) crpm))
  (entmod crpm)
  (entupd (cdr (assoc -1 crpm)))
  (prin1)
)
şeklinde değiştirirseniz daha doğru olacaktır.


kolay gelsin.

04.02.2011 09:45    

emasi
Teşekkürler hocam:)

04.02.2011 10:38    

lazymelisa
[url=http://img808. Imageshack. Us/i/cadg. png/][img]http://img808. Imageshack. Us/img808/2881/cadg. Png[/img][/url]

uploaded with ımageshack. Us

burdaki sayıları toplamak istiyorum

ProhibiT (05.12.2011 17:52 GMT)

04.02.2011 10:46    

emasi
Link açılmır ki:(

04.02.2011 10:47    

lazymelisa



beceremedm ki bi resim eklemeyi


!
!
! ¢0. 50 m
!
!
!
! ¢ 0. 45 m

!______________________________






böle bişi bunu toplicam bazen nokta yerine virgün de oluyo bazen sonunma m de yazmıo böle bişi iste

ProhibiT (05.12.2011 17:54 GMT)

06.02.2011 21:55    

ProhibiT
Yukarıda paylaştığım fonksiyonu değiştirip geliştirerek yeniden paylaşıyorum. Bu haliyle sizin ihtiyacınızı da göreceğini sanıyorum. toplamak üzere seçeceğiniz text veya mtext türü objelerin içinde nümerik olmayan karakterler olabilir, hatta tamamı alfanümerik bile olabilir. toplam yazdırılırken, toplanan objelerde kullanılan para birimi ve diğer birimler gözardı edilir yazılmazlar.
Kod:

;;| 2011 yılında yazılıp autocadokulu.com (cizimokulu.com) sitesinde           |
| paylaşılan, seçilen yazılar (text veya mtext) içindeki sayıları            |
| ayıklayaraktoplamını gösterilen yerdeki yazının sayısal içeriğini          |
| güncelleyerekveya seçilen yer boş ise yeni bir text nesnesi oluşturarak    |
| yazan bu sayı toplama fonksiyonu, Ekim 2020'de güncellenerek,              |
| yazı içinde boşluk (ascii 32) karakteri bulunması durumunda da             |
| toplamı hesaplayacak şekildegüncellendi. 09.10.2020 -                      |
|                   son düzenleme: 10.06.2023 - M. Şahin Güvercin (ProhibiT) |;
(defun c:tpLm (/ *error* tpLn L n txh pvt m o rsLt tpLm)
  (setq ocmd (getvar "cmdecho"))
  (defun *error* (er /)
    (if (member er '("Function cancelled" "quit/exit abort"))
      (princ (strcat "\n\t*error* " er)))
    (if (= (logand (getvar "undoctl") 8) 8) (command-s "_.undo" "e"))
    (if ocmd (setvar "cmdecho" ocmd)) (prin1))
   (command "undo" "group") (setvar "cmdecho" 0)
  (princ "\n  toplanacak sayıları seçiniz")
  (setq tpLn (ssget (list (cons 0 "*text")))
        L    (sslength tpLn) n -1 rsLt nil
        txh  (cdr (assoc 40 (entget (ssname tpLn 0)))))
  (while (< (setq n (1+ n)) L)
    (setq pvt (cdr (assoc 1 (entget (ssname tpLn n)))) m (strlen pvt) o 0)
    (while (<= (setq o (1+ o)) m)
      (if (= (substr pvt o 1) (chr 32)) (setq o (1+ o)))
      (if (= (substr pvt o 1) (chr 44))
        (setq pvt (strcat (substr pvt 1 (1- o)) (chr 46)
                          (substr pvt (1+ o) (- m o)))))
      (if (or (< (ascii (substr pvt o 1)) 44) (> (ascii (substr pvt o 1)) 57))
        (setq pvt (strcat (substr pvt 1 (1- o)) (substr pvt (1+ o) (- m o)))
              m (strlen pvt) o (1- o))))
    (if rsLt (setq rsLt (+ rsLt (atof pvt))) (setq rsLt (atof pvt))))
  (princ "\n    toplam yazısı/yeri seçiniz")
  (while (/= 3 (car (setq sp (grread t 4 2)))))
  (setq sp (cadr sp) np (list (car sp) (cadr sp)) tpLm (ssget np))
  (if tpLm
    (progn (setq tpLm (entget (ssname tpLm 0)))
      (if (or (= (cdr (assoc 0 tpLm)) "TEXT")
              (= (cdr (assoc 0 tpLm)) "MTEXT"))
        (progn (setq tpLm (subst (cons 1 (rtos rsLt)) (assoc 1 tpLm) tpLm))
          (entmod tpLm) (entupd (cdr (assoc -1 tpLm))))))
    (entmake (list (cons 0 "text") (cons 10 sp) (cons 50 0) (cons 40 txh)
                   (cons 1 (rtos rsLt)))))
   (if (= (logand (getvar "undoctl") 8) 8) (command-s "_.undo" "e"))
  (if ocmd (setvar "cmdecho" ocmd)) (prin1))

- Toplanmak üzere seçilen text objelerinin içinde virgül varsa nokta olarak alınır.
- Söz konusu text objelerinin içinde nümerik olmayan karakterler varsa, gözardı edilir.
- Sonuçlar yazdırılmak üzere seçim yapmanız istendiğinde tıkladığınız noktada bir text ya da mtext varsa onun içeriği değiştirilerek toplam değer yazılır. eğer tıklanan noktada text veya mtext türü bir obje yoksa, yeni bir text objesi oluşturularak toplam yazılır.

* 9 Ekim 2020 tarihinde seçilen yazılar içinde boşluk karakteri olması durumu da göz önüne alınarak güncellendi.
* 10 Haziran 2023 tarihinde yeniden düzenlendi.
kolay gelsin.

ProhibiT (10.06.2023 15:59 GMT)

08.03.2011 08:17    

aytac_kavak
Tesekkurler prohibit hocam cok işimize yaradı kolaygelsın

08.12.2011 15:38    

xguvenx
Çok sağolasın hocam çok makbule geçti bu lips bunu yana yana arıyordum allah razı olsun keşke birde sonuçları noktadan sonra 2 hane yazsaydı ama olsun bunada şükür

09.12.2011 12:53    

ProhibiT
Dimzin ve luprec sistem değişkenlerini uygun şekilde ayarlayarak istediğiniz gibi yazdırabilirsiniz. buna rağmen, fonksiyon kodunu, ondalık basamak sayısını kullanıcı belirleyecek şekilde değiştirerek güncelledim. tekrar indirip kullanabilirsiniz...

01.06.2015 14:00    

xpitonx_54
Arkadaşlar merhaba ,
Toplama lisp inde seçilen yazıların aritmetik ortalamasını yazdırmak ve aynı zamanda bu değer "Z" değeri olacak bir point oluşturmak istiyorum ama nasıl yapacağımı bilmiyorum.Yardımcı olursanız sevinirim.Şimdiden teşerkkürler..

07.07.2015 12:23    

Travaci
Alıntı
xpitonx_54

Kod:

(defun c:typ (/ e r k a n) (vl-load-com)
  (defun *error* (msg)
    (if (not (wcmatch (strcase msg t) "*cancel*,*exit*"))
      (princ (strcat "\nError: " msg))) (setq *error* nil) (princ))
  (if (setq e (ssget (list (cons 0 "*text"))))
    (progn (setq r 0 k 0)
      (repeat (setq r (sslength e))  
        (setq k (+ k (atof (cdr (assoc 1 (entget (ssname e (setq r (1- r))))))))))
      (if (setq a (getpoint "\nSpecify point:"))
        (progn
          (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
          (entmake (list (cons 0 "text") (cons 10 (trans a 1 0)) (cons 72 1)
            (cons 11 (trans a 1 0)) (cons 40 (getvar "textsize")) (cons 73 1) 
              (cons 1 (rtos (setq n (/ k (sslength e))) 2 (getvar "dimdec")))))
          (entmake (list (cons 0 "point") (cons 10 (trans (list (nth 0 a) (nth 1 a) n) 1 0))))
          (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
        )
      )
    )
  ) (setq *error* nil) (princ)
)

10.07.2015 07:05    

xpitonx_54
Saygıdeğer editörümüz "Travaci" , alakanızdan ve yardımınızdan ötürü sonsuz teşekkürlerimi sunarım.
Saygılarımla...

01.10.2020 16:33    

elk21
[img][/img]

HOCAM ÖNCELİKLE TEŞEKKÜRLER BÖYLE BİR LİSP OLUŞTURDUĞUNUZ İÇİN UZUN ZAMANDIR BÖYLE BİRŞEY ARIYORDUM FAKAT TOPLUYORUM YALNIŞ ÖLÇÜYOR SİZE ZAHMET BANA YARDIMCI OLURMUSUNUZ SAYGILARIMLA HÜRMET EDERİM

01.10.2020 18:06    

Travaci
Alıntı
elk21 :

Sayı önündeki yazı yüzünden işlem yapmıyor.

01.10.2020 20:57    

elk21
Teşekkür ederim verdiğiniz bilgi için peki hocam böyle yazılı bir yerde masıl toplama yapabiliriz buna uygun bir lisp varmıdır.saygılarımla

03.10.2020 00:23    

alumina
Alıntı
elk21 :

Kod:

(defun c:qw (/ tx)
  (if (ssget '((0 . "*text") (1 . "*[Mm]2*")))
    (alert (strcat "Total: " (rtos (apply '+
      (mapcar '(lambda(a) (atof (substr
        (setq tx (cdr (assoc 1 (entget a))))
          (1+ (vl-string-position (ascii " ") tx 1)))))
            (vl-remove-if 'listp (mapcar 'cadr
              (ssnamex (ssget "_P")))))) 2 2) " M2")
    )
  ) (princ)
)

08.10.2020 14:42    

elk21
Alıntı
ALUMİNA




SAYGIDEĞER HOCAM ÖNCELİKLE TEŞEKKÜR EDERİM FAKAT VERMİŞ OLDUĞUNUZ LİSP YÜKLEDİM AMA ÇALIŞMIYOR SAYGILARIMLA

Copyright © 2004-2022 SQL: 2.723 saniye - Sorgu: 101 - Ortalama: 0.02697 saniye