excel icin lisp | Forumlar

Forum Menüsü

AutoCAD Genel

AutoCAD Eğitimi

3ds Max

Ziyaretçi: 355, Üye: 0

Detaylar »

Forumlar > AutoLISP > excel icin lisp

Bu başlığı inceleyenler : 1 ziyaretçi, 0 üye : ---

İleti	Yazar
27.06.2022 09:39 89638	nurali Girişimci 1 ileti tekniker münchen
Merhaba Arkadaslar, uzun zamandir ayri kalmistim siteden.belki de daha once sorulup cevaplanmis bir konuda ricam olacak.simdiden anlayisiniz icin tesekkur ederim. Arkadaslar ben autocad 2020 kulaniyorum. bana asagidaki lispler lazim: 1. autocad de otomatik (netcad de atildigi gibi) nokta atma (tabi varsa) lispi 2.noktalari autocadden excele-excelden autocade aktarma lispi 3.herhangi bir yerin-kosenin veya noktanin koordinatini ekrana yazdirma lispi. belirtigim gibi belki daha once yayinlamis lispler bunlar. yine de yardimci olmanizi rica edebilir miyim? selamlar iyi calismalar.. nurali savas

13.07.2022 08:12 89649	baha07 Kıdemli Uzman 108 ileti harita teknikeri antalya
Kod: ; Otomatik Koordinat Ekleme ; Sertan Turkan ; ; Kisitlama ; ---------- ; Geзerli kilavuz "leader" stili ve birim ayarlari kullanilacaktir. (defun c:lb (/ p x y ptcoord textloc) (while (setq p (getpoint "\nKOORDINATINI YAZDIRMAK ISTEDIGINIZ NOKTAYI TIKLAYIN: ")) (setq textloc (getpoint "\nKILAVUZUN KONUMUNU TIKLAYIN: ")) (setq x (rtos (car p))) (setq y (rtos (cadr p))) (setq z (rtos (caddr p))) (setq ptcoord (strcat y " " x " " z)) (command "_LEADER" p textloc "" ptcoord "") ) ) ProhibiT (18.07.2022 08:20 GMT)

17.07.2022 18:27 89667	alumina Editör 769 ileti Insaat Muhendisi Istanbul
Sahin hocam nokta koordinatini ekrana yazdirma lispini ("kyaz") 2011 yilinda yazmis zaten. Bende ogrenmeye calisan arkadaslar icin degisik bir sekilde yazdim.. Kod: ;**Ekranda gosterilen noktanin koordinatlarini istenilen ; sirada, cerceve icerisinde WCS'de yazar. Yazi yuksekligi ; 'TextSize, virgulden sonrki basamak sayisi 'Luprec ; sistem degiskenine baglidir** (defun c:cr (/ dc n0 nw n a1 a2 th tx ty tz xy ls lt dz lc lm ln m1 m2 m3 ly p0 pz np nl pt ax) (vl-load-com) (setq dc (vla-get-ActiveDocument (vlax-get-acad-object)) n0 '(0. 0.) nw n0 a1 (/ pi 2.) a2 (+ a1 pi) th (getvar 'TextSize) tz (/ th 2.) ty (* th 5.)) (initget "XYZ XZY YXZ YZX ZXY ZYX") (if (setq xy (getkword "\nSorting type? [XYZ/XZY/YXZ/YZX/ZXY/ZYX]:")) (while (setq lm nil ls nil lt nil n0 nw n 0 dz (getvar 'DimZin) p0 (getpoint "\nPoint:")) (vla-StartUndomark dc) (setvar 'DimZin 0) (setq p0 (trans p0 1 0) pz (caddr p0) lc (mapcar '(lambda(a) (rtos a 2 (getvar 'Luprec))) p0) ln (list (list "X" (car lc)) (list "Y" (cadr lc)) (list "Z" (caddr lc)))) (setvar 'DimZin dz) (repeat 3 (setq n (1+ n) lm (append lm (list (substr xy n 1))))) (mapcar '(lambda(a b) (setq ls (cons (vlax-ename->vla-object (entmakex (list '(0 . "Text") (cons 1 (strcat a ": " (cadr (nth (vl-position a (mapcar 'car ln)) ln)))) (cons 8 (strcat a " Coordinate")) (cons 10 (list tz (* tz b) pz)) (cons 40 th)))) ls))) lm (list 7. 4. 1.)) (foreach m ls (vla-GetBoundingBox m 'mn 'mx) (setq lt (cons (car (vlax-safearray->list mx)) lt))) (setq tx (+ tz (apply 'max lt)) m1 (list tx 0.) m2 (list tx ty) m3 (list 0. ty) ly '(8 . "Frame") np (vlax-ename->vla-object (entmakex (append (list '(0 . "LwPolyline") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") ly (cons 38 pz) '(90 . 4) '(70 . 1)) (mapcar '(lambda(a) (cons 10 a)) (list n0 m1 m2 m3))))) nl (vlax-ename->vla-object (entmakex (list '(0 . "Line") ly (cons 10 p0) (cons 11 p0)))) ls (cons np ls)) (while (/= 3 (car (setq pt (grread T 1 0)))) (setq pt (cadr pt) ax (angle p0 pt)) (vlax-put nl 'EndPoint (list (car pt) (cadr pt) pz)) (setq pt (mapcar '- pt (cond ((and (>= ax 0.) (< ax a1)) nw) ((and (>= ax a1) (< ax pi)) m1) ((and (>= ax pi) (< ax a2)) m2) ((and (>= ax a2) (< ax (* 2. pi))) m3)))) (foreach m ls (vla-TransformBy m (vlax-tmatrix (list (list 1 0 0 (- (car pt) (car n0))) (list 0 1 0 (- (cadr pt) (cadr n0))) '(0 0 1 0) '(0 0 0 1))))) (setq n0 pt) ) (vla-EndUndomark dc) ) ) (prin1) )

18.07.2022 12:35 89668	ProhibiT Yetkili 1611 ileti İnşaat Mühendisi Ankara
Merhaba, Adem arkadaşımız özel mesaj yazmış, "Hocam merhaba, Forumda excel le ilgili bir konu açılmış ve bir arkadaş basitce ekrana koordinat yazdirma lispi paylaşmiş. Bende sizin 2011 yılında yazdığınız (kyaz) lispine atıfta bulunarak degişik bir yolla yazdim. Herhalde 5 ay olmuştu kod yazmayalı. Gördüğünüzde değerli yorumlarınızı beklerim..." demiş. Adem Ercan arkadaşımızın sözünü ettiği "kyaz" Lisp'ini sitede de bilgisayarımda da bulamadım. Cengiz Kılıç arkadaşımızada olabilir, paylaşımlarımın arşivini tutuyordu. :) Paylaşılan kodları gözden geçirince konuyu hatırlar gibi oldum. :) Mesajdaki "değerli yorumlarınızı beklerim..." ifadesi bende değişik duygular uyandırdı. Zaman zaman Adem ve Erkan arkadaşlarımıza "Kod Zaptiyesi" diye takılıyorum. :) Yazdıklarımı ve paylaştıklarımı en acımasızca didikleyen, (yapıcı anlamda) eleştiren arkadaşlarımıza (ki, Mehmet Şamil hocam da eleştirir, ama ortalıktan yazmaz, özel muhabbetlerimizde paylaşır) şükran borçluyum. Bunu ifade ettikten sonra, tarafımdan yazılan eleştirilerin (bu arkadaşlarımız dışında) biraz yanlış anlaşıldığını düşünüyorum. Sanki her yapılanı eleştiren, her işte bir eksik, bir kusur arayan biriymişim gibi algılanıyor. Halbuki "Dibek dövücünün hınk deyicisi" misali, yazan üreten herkese destek olmak isterim doğrusu. Bazen böyle deyimler kullanıyorum. İlgi duyanlar ve sevenlere, facebook'ta https://www.facebook.com/media/set/?vanity=m.sahin.guvercin&set=a.1157806497604739 linkinden ulaşabileceğiniz "Doğru Türkçe" albümünü tavsiye ederim. Gelelim konumuza... Kodlar için söylenebilecek fazla bir şey yok, eline sağlık; amacına ulaşan, derli toplu yazılmış bir kod. Lisp kodlarında, her kodun besmelesi gibi; (setq dc (vla-get-ActiveDocument (vlax-get-acad-object)) ifadesinin (haşırt to the blackboard) kullanılmasına karşıyım biliyorsunuz. Çoklu dosyada çalışılmadığı sürece pekte gereği olmayan böyle satırların yazılması, tamamen alışkalıktan kaynaklanıyor diye düşünüyorum. Eğer, (vla-EndUndomark dc) kısmında kullanıyorum derseniz... onun yerine (command "undo" "m") yazmakla işi gene halledersiniz. Birinde "Mark encountered" diğerinde "GROUP" iletisini alırsınız, o kadar. Alışkanlıklarımıza esir olmamak, yeni öğrenen ve kullananların zihnini karıştırmamak daha doğrudur. Kod: (setq p0 (trans p0 1 0) pz (caddr p0) lc (mapcar '(lambda(a) (rtos a 2 (getvar 'Luprec))) p0) ln (list (list "X" (car lc)) (list "Y" (cadr lc)) (list "Z" (caddr lc)))) Bölümünde WCS'den UCS'ye çevrilen koordinatlardan Z (nümerik değeri) pz değişkeninde saklanmış. Koordinat yazısı oluşturulurken de; Kod: (mapcar '(lambda(a b) (setq ls (cons (entmakex (list '(0 . "Text") (cons 1 (strcat a ": " (cadr (nth (vl-position a (mapcar 'car ln)) ln)))) (cons 8 (strcat a " Coordinate")) (cons 10 (list tz (* tz b) pz)) (cons 40 th)))) ls))) lm (list 7. 4. 1.)) şeklinde kullanılmış. Bu durumda Koordinat Listesindeki her koordinat ilgili noktanın z değerinde (kotunda) oluşturuluyor. Bu da amaca yönelik doğru işlem. entmake ve entmakex biribirine çok benzer, ürettikleri sonuç değer (return value, geri dönüş değeri) birinde association list iken diğerinde doğrudan entity name olduğundan... burada son derece doğru kullanılmış. Sorting Type (Sıralama Tipi) kavramına neden ihtiyaç duyulduğunu anlayamadım. Belki Haritacı arkadaşların böyle bir kullanım ihtiyacı oluyordur. Oluşturulan (çerçeveli) Koordinat Listesinin her nokta için sürükle bırak (drag and drop) yöntemiyle yerleştirilmesi, kodlama ve programatik açıdan hoş olmuş. Ama, bunun kullanıcıya ne sağladığı, hataya neden olması ihtimali tartışılabilir. Ayrıntıya girilirse, sürükleyip bırakma işlmi sırasında, Koordinat Sistemi UCS (geçerli User Coordinate System), pz değişkeninin değeri WCS (World Coordinate System) de olacağından, (hele birde ucsfollow sistem değişkeni uygun değilse) sürüklenen nokta ekranın dışındaymış gibi, hareket ettirememe (ya da uzaklaşırkan yaklaşıyor görünme) durumu ortaya çıkabilir. Bunu engellemek için sürükleme işlemi sırasında pz'nin UCS'ye transform edilmiş hali kullanılablir. "kyaz" Lisp'ini ararken bizim meşhur PCT (Point Coordinate Table) Lisp'i aklıma geldi. Onu da da 2011 yılında (hatta ilk sürümünü 2010 yılında) paylaşmışız. https://cizimokulu.com/page.php?id=970 Bu paylaşımlarımızda, teker teker seçilen noktalar değil de, point veya circle nesnelerinin tanımladığı nokta koordinatlarının tablo olarak düzenlenmesini, eğer istenirse de Koordinat Tablosunun Excel'e aktarılmasını hedeflemiştik. Tablodaki koordinatlarda "noktalar" arasındaki ilişkiyi de her bir noktaya numara (veya isim) vererek kurmuştuk. Noktalara Numara verildiği için, Nokta koordinatlarının Satır düzeninde mi, Sütun düzeninde sıralanacağı konusu önemli idi. Söylediğim gibi "kyaz" lispini bulamadığım için kıyaslayamadığımdan PCT ile kıyasladım. Eh! benzerlikler olmakla birlikte tamamen farklı işlemleri, farklı amaca yönelik yapıyorlar. Bu yazılan Lisp için bir tavsiyem var. :) Koordinat Listesinin ucunda seçilen noktayı gösteren (Leader gibi) bir çizgi var ya... işte o çizginin ucu (StartPoint/EndPoint) Field ile Koordinat listesinin İlgili (X, Y veya Z) koordinatına bağlanırsa, oluşturulan koordinatlar çizgi (koordinat listesi ve çerçevesi ile birlikte) ötelendikçe veya sündürüldükçe değişir... Selam ve saygılarımla herkese kolaylıklar dilerim. ProhibiT (18.07.2022 13:02 GMT) Beğenmek için anlamak lazım...

18.07.2022 12:59 89669	Travaci Editör 2392 ileti Teknik Ressam Konstantinopol
ProhibiT Bu olsa gerek :) Linkleri görebilmek için ÜYE olmalısınız.

18.07.2022 13:09 89670	ProhibiT Yetkili 1611 ileti İnşaat Mühendisi Ankara
Daha da eskisini buldum... https://cizimokulu.com/forums.php?m=posts&p=55376#55376 bunu 2010 yılında paylaşmışız. Tarihe malolumuş, desek abartı olmaz. Ama Adem bir kaç yerde ısrarla "kyaz" dediğine göre vardır bir bildiği. :) Beğenmek için anlamak lazım...

18.07.2022 13:10 89671	Travaci Editör 2392 ileti Teknik Ressam Konstantinopol
Bende başka bir kodunuzu hatırlıyorum muhtemelen arşiv silindi.

18.07.2022 16:10 89672	alumina Editör 769 ileti Insaat Muhendisi Istanbul
Alıntı ProhibiT : Hocam yorumlariniz icin tesekkur ederim. Kod, while ile surekli koordinat yazdigi icin herhangi bir anda programi sonlandirip geriye dogru tek tek silmek icin start ve end kullandim. Malum command'i kullanmamaya calisiyoruz :) Sizin yazdiginiz kodla birebir ayni islemi yapan kodu degisik bir sekilde yazdim. Tek fark sizde yazi yuksekligi ve virgulden sonraki basamak sayisi soruluyor. Bende direkt olarak 'TextSize ve 'Luprec degerleri aliniyor.. Basinda adiniz yazmasa bile yazim sekli zaten sizin yazdiginizi soyluyor :) Kod: ;;; Seçilen noktadan bir çizgi çizerek, çizginin diğer ucuna kutu içinde ;;; ;;; noktanın X, Y ve Z koordinatlarından birini veya birkaçını istenilen ;;; ;;; sırada ve aktif UCS değerlerini yazar... ;;; ;;; Hazırlayan: M. Şahin Güvercin ;;; ;;; www.autocadokulu.com 15.10.2011 ;;; (princ "\n Hazırlayan: M. Şahin Güvercin - www.autocadokulu.com - ") (defun c:kyaz (/ error odz mto TxH dp ub msg cnt crd L n sps n1 xLr yLr n0 mvo yz ni n2 n3 n4 n5 sto Lx Ly onK nnK aci a1 a2 dsp) (defun error (err) (setvar "dimzin" odz) (command "_.undo" "e") (princ (strcat "\n" err)) (setq error nil)) (setvar "cmdecho" 0) (vl-load-com) (command "_.undo" "group") (setq odz (getvar "dimzin")) (setvar "dimzin" 0) (if (not (tblsearch "Layer" "Koordinat")) (entmake (list (cons 0 "LAYER") (cons 62 1) (cons 70 0) (cons 2 "Koordinat") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord")))) (if (not odp) (setq odp (getvar "dimdec"))) (if (setq dp (getint (strcat "\n Ondalık Basamak <" (itoa odp) ">: "))) (setq odp dp) (setq dp odp)) (if (not oth) (setq oth (getvar "TextSize"))) (if (setq TxH (getreal (strcat "\n Yazı Yüksekliği <" (rtos oth 2 dp) ">: "))) (setq oth TxH) (setq TxH oth)) (if (not oub) (setq oub "")) (setq ub (getstring (strcat "\n Uzunluk Birimi <" oub ">: "))) (if (= (substr ub 1 1) "-") (setq ub "" oub ub) (if (= ub "") (setq ub oub) (setq oub ub))) (setq msg (strcat "\n Yazılacak Koordinat(lar) (Y, X ve Z'nin her türlü" " bileşimi, istenen sırada girilebilir): ") cnt nil) (while (not cnt) (initget 1) (setq crd (strcase (getstring msg)) L (strlen crd) n 0) (while (<= (setq n (1+ n)) L) (if (or (< (ascii (substr crd n 1)) 88) (> (ascii (substr crd n 1)) 90)) (progn (princ "\n Hatalı giriş!") (setq cnt nil)) (setq cnt T)))) (setq sps (* 0.42426 TxH) msg "\n İlk Noktayı seçiniz... ") (while (setq n1 nil xlr nil ylr nil n0 (getpoint msg)) (setq n0 (trans n0 1 0) mvo (ssadd) n1 (list (+ (car n0) sps) (+ (cadr n0) sps) (caddr n0)) msg "\r ... Yeni Nokta seçiniz: " L (strlen crd) n 0) (while (<= (setq n (1+ n)) L) (cond ((= (ascii (substr crd n 1)) 89) (setq yz (strcat "Y : " (rtos (car (trans n0 0 1 nil)) 2 dp)))) ((= (ascii (substr crd n 1)) 88) (setq yz (strcat "X : " (rtos (cadr (trans n0 0 1 nil)) 2 dp)))) ((= (ascii (substr crd n 1)) 90) (setq yz (strcat "Z : " (rtos (caddr (trans n0 0 1 nil)) 2 dp))))) (entmake (list (cons 0 "Text") (cons 8 "Koordinat") (cons 40 TxH) (cons 50 0) (cons 1 (strcat yz " " ub)) (cons 10 n1))) (ssadd (entlast) mvo) (setq ni (cdr (assoc 10 (entget (entlast)))) n2 (textbox (entget (entlast))) n4 (cadr n2) n2 (car n2) n2 (mapcar '(lambda (p1 p2) (+ p1 p2)) ni n2) n4 (mapcar '(lambda (p1 p2) (+ p1 p2)) ni n4) xlr (append xlr (list (car n2) (car n4))) ylr (append ylr (list (cadr n2) (cadr n4))) n1 (list (car n1) (- (cadr n1) (* 1.5 TxH)) (caddr n0)))) (setq xlr (vl-sort xlr '<) ylr (vl-sort ylr '<) n2 (list (nth 0 xlr) (nth 0 ylr) (caddr n0)) n4 (list (nth (1- (length xlr)) xlr) (nth (1- (length ylr)) ylr) (caddr n0)) n2 (list (- (car n2) sps ) (- (cadr n2) sps) (caddr n0)) n4 (list (+ (car n4) sps) (+ (cadr n4) sps) (caddr n0)) n3 (list (car n4) (cadr n2) (caddr n0)) n5 (list (car n2) (cadr n4) (caddr n0)) Lx (distance n2 n3) Ly (distance n3 n4) onK n2) (entmake (list (cons 0 "Line") (cons 8 "Koordinat") (cons 10 n0) (cons 11 n2))) (setq sto (entget (entlast))) (entmake (list (cons 0 "LwPoLyLine") (cons 100 "AcDbEntity") (cons 67 0) (cons 8 "Koordinat") (cons 100 "AcDbPolyline") (cons 90 4) (cons 10 n2) (cons 10 n3) (cons 10 n4) (cons 10 n5) (cons 70 1) (cons 38 (caddr n2)))) (ssadd (entlast) mvo) (while (/= 3 (car (setq nnK (grread T 4 0)))) (setq nnK (trans (cadr nnK) 1 0 nil) nnK (list (car nnK) (cadr nnK) (caddr n0)) aci (angle n0 nnK) a1 (/ pi 2.0) a2 (* 1.5 pi) sto (subst (cons 11 nnK) (assoc 11 sto) sto) L (sslength mvo) n -1) (entmod sto) (entupd (cdr (assoc -1 sto))) (cond ((and (>= aci 0) (<= aci a1)) (setq dsp (mapcar '(lambda (p1 p2) (- p1 p2)) nnK n2) n2 nnK n3 (polar n2 0 Lx) n4 (polar n3 a1 Ly) n5 (polar n4 pi Lx))) ((and (> aci a1) (<= aci pi)) (setq dsp (mapcar '(lambda (p1 p2) (- p1 p2)) nnK n3) n3 nnK n4 (polar n3 a1 Ly) n5 (polar n4 pi Lx) n2 (polar n5 a2 Ly))) ((and (> aci pi) (<= aci a2)) (setq dsp (mapcar '(lambda (p1 p2) (- p1 p2)) nnK n4) n4 nnK n5 (polar n4 pi Lx) n2 (polar n5 a2 Ly) n3 (polar n2 0 Lx))) ((and (> aci a2) (< aci (* pi 2))) (setq dsp (mapcar '(lambda (p1 p2) (- p1 p2)) nnK n5) n5 nnK n2 (polar n5 a2 Ly) n3 (polar n2 0 Lx) n4 (polar n3 a1 Ly)))) (while (< (setq n (1+ n)) L) (vla-transformby (vlax-ename->vla-object (ssname mvo n)) (vlax-tmatrix (list (list 1 0 0 (car dsp)) (list 0 1 0 (cadr dsp)) (list 0 0 1 0) (list 0 0 0 1))))) (setq onK nnK))) (setq error nil) (setvar "dimzin" odz) (command "_.undo" "e") (prin1) )

18.07.2022 22:06 89673	ProhibiT Yetkili 1611 ileti İnşaat Mühendisi Ankara
"Sen de az kirli çıkı değilsin..." diyesim geldi :) Böyle bir şeyi değil bilgisayarımda bulmayı, yazdığımı bile unutmuştum. Bleki de şantiyelerden birinde topoğraf arkadaşlar istemişti. Hayal meyal öyle bir şey hatırlıyorum. Burada yazdığım hata yakalama işlevini (error) görmezden gelin, bu konuda o zamandan beri fikirlerim epeyce değişti. X, Y ve Z koordinatlarına göre sıralama yaparken ben itin ayağını taştan sakınmamışım, sen INITGET ve GETKWORD kullanarak çok daha sade çözmüşsün. Varsayılan değeri ekran mesajında hatırlatıp, enter ile geçilince varsayılan değeri alması sağlanabilir. Bunun yanında ben "Koordinat" isimli Layer'ın mevcut olup olmadığını kontrol etmişim, yoksa oluşturmuşum. Sen doğrudan kullanmışsın ve her koordinat (X, Y ve Z) için ayrı layer kullanmışsın. Belki o zamanki AutoCad sürümlerinde Layer'ı önceden oluşturmak gerekiyordu... hatırlamıyorum. Daha pek çok detayı daha kestirme, daha sade yoldan çözmüşsün. İlk yorumumda yazdığım Drag and Drop sırasında koordinat sistemi transformasyonu konusunu dikkate almanı tavsiye ederim. Ve elbette daha önce sözünü ettiğim "Field" (abartırsak reactor de olabilir) konusunu gözden uzak tutma derim. :) Kolay gelsin. Beğenmek için anlamak lazım...

19.07.2022 10:35 89678	alumina Editör 769 ileti Insaat Muhendisi Istanbul
Hocam, getkword icin varsayilan degeri (bu deger haritacilar total station'a nokta girerken genelde YXZ siralamasindadir) belittik. sürükleyip bırakma işlmi sırasında, Koordinat Sistemi UCS (geçerli User Coordinate System), pz değişkeninin değeri WCS (World Coordinate System) de olacağından, (hele birde ucsfollow sistem değişkeni uygun değilse) sürüklenen nokta ekranın dışındaymış gibi, hareket ettirememe (ya da uzaklaşırkan yaklaşıyor görünme) durumu ortaya çıkabilir. ornegin 500 birim yukseklikteki bir noktanin koordinatlari yazdirilirken dediginiz gibi kursor ekran disinda hareket ediyor. Yukseklik degeri 10 birim olan nokta icinse kursor z koordinatini 0 olarak kabul edip planda hareket ediyordu. Bu olay nokta transformasyonu ile halledilebilecek bir sey gibi gelmedi bana. (belkide halledilir) Bu nedenle drag ve drop tan hemen once modelspace in elevation degerini pz ye editledik. Field i da Erkan eklesin :)) Kod: ;**Ekranda gosterilen noktanin koordinatlarini istenilen ; sirada, cerceve icerisinde WCS'de yazar. Yazi yuksekligi ; 'TextSize, virgulden sonrki basamak sayisi 'Luprec ; sistem degiskenine baglidir** (defun c:cr (/ dc n0 nw n a1 a2 th el tx ty tz xy ls lt dz lc lm ln m1 m2 m3 ly p0 pz nl pt ax) (vl-load-com) (setq dc (vla-get-ActiveDocument (vlax-get-acad-object)) n0 '(0. 0.) nw n0 a1 (/ pi 2.) a2 (+ a1 pi) th (getvar 'TextSize) el (getvar 'Elevation) tz (/ th 2.) ty (* th 5.)) (initget 0 "XYZ XZY YXZ YZX ZXY ZYX") (if (not (setq xy (getkword "\nSorting type? [XYZ/XZY/YXZ/YZX/ZXY/ZYX] <YXZ>:"))) (setq xy "YXZ")) (while (setq lm nil ls nil lt nil n0 nw n 0 dz (getvar 'DimZin) p0 (getpoint "\nPoint:")) (vla-StartUndomark dc) (setvar 'DimZin 0) (setq p0 (trans p0 1 0) pz (caddr p0) lc (mapcar '(lambda(a) (rtos a 2 (getvar 'Luprec))) p0) ln (list (list "X" (car lc)) (list "Y" (cadr lc)) (list "Z" (caddr lc)))) (setvar 'DimZin dz) (repeat 3 (setq n (1+ n) lm (append lm (list (substr xy n 1))))) (mapcar '(lambda(a b) (setq ls (cons (vlax-ename->vla-object (entmakex (list '(0 . "Text") (cons 1 (strcat a ": " (cadr (nth (vl-position a (mapcar 'car ln)) ln)))) (cons 8 (strcat a " Coordinate")) (cons 10 (list tz (* tz b) pz)) (cons 40 th)))) ls))) lm (list 7. 4. 1.)) (foreach m ls (vla-GetBoundingBox m 'mn 'mx) (setq lt (cons (car (vlax-safearray->list mx)) lt))) (setq tx (+ tz (apply 'max lt)) m1 (list tx 0.) m2 (list tx ty) m3 (list 0. ty) ly '(8 . "Frame") ls (cons (vlax-ename->vla-object (entmakex (append (list '(0 . "LwPolyline") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") ly (cons 38 pz) '(90 . 4) '(70 . 1)) (mapcar '(lambda(a) (cons 10 a)) (list n0 m1 m2 m3))))) ls) nl (vlax-ename->vla-object (entmakex (list '(0 . "Line") ly (cons 10 p0) (cons 11 p0))))) (while (/= 3 (car (setq pt (grread T 1 0)))) (setq pt (cadr pt) ax (angle p0 pt)) (vlax-put nl 'EndPoint (list (car pt) (cadr pt) pz)) (setvar 'Elevation pz) (setq pt (mapcar '- pt (cond ((and (>= ax 0.) (< ax a1)) nw) ((and (>= ax a1) (< ax pi)) m1) ((and (>= ax pi) (< ax a2)) m2) ((and (>= ax a2) (< ax (* 2. pi))) m3)))) (foreach m ls (vla-TransformBy m (vlax-tmatrix (list (list 1 0 0 (- (car pt) (car n0))) (list 0 1 0 (- (cadr pt) (cadr n0))) '(0 0 1 0) '(0 0 0 1))))) (setq n0 pt)) (vla-EndUndomark dc) ) (setvar 'Elevation el) (prin1) )

19.07.2022 11:42 89679	ProhibiT Yetkili 1611 ileti İnşaat Mühendisi Ankara
Emeğine sağlık, Erkan Travacı'ya da kolay gelsin. :) Cordinat transferi (trans...) konusunda epeyce açık ipucu verdiğimi düşünürken, "deli kuyuya taş attı" misali... epeyce uğraştırmış seni. Kast ettiğim, ekrandan okunan (pt değişkeninen atanan) koordinat değerinin çevrilmesi idi. Bu çevirme işlemi ni 1'den 0'a (UCS'den WCS'ye) transfer işlemi tereddütsüz uygulanabilir. Kullanıcı UCS'de çalışıyorsa transfer işlemi gerçekleşir. Eğer WCS'de çalışıyorsa (ki o zaman da WCS=DCS=UCS olacağından) çaktırmadan 0'dan 0'a transform etmiş oluruz. Kullanıcı açısında da, üretilen sonuçlar açsından da her hangi bir sıkıntı yaşanmaz. Bu mantıkla düzenlediğim halini paylaşıyorum. Son halini alınca, kafa karıştırıcı olmaması (arayanların kaybolmaması) için ara sürümleri temizlemek iyi olacak herhalde. Görüldüğü gibi, grread ile okunan koordinat değerini (setq pt (trans (cadr pt) 1 0) şeklinde sorgusuz sualsiz 1'den 0'a çeviriyor. ProhibiT (19.07.2022 20:04 GMT) Beğenmek için anlamak lazım...

19.07.2022 12:20 89682	alumina Editör 769 ileti Insaat Muhendisi Istanbul
Hocam, Yaptigim denemelerde gerek ucs de gerekse wcs de olsun grread den donen degerin trans la cevrilmesine ihtiyac olmadigini gordum. getkword icin varsayilan deger ve elevation eklenmis son hali.. Kod: ;**Ekranda gosterilen noktanin koordinatlarini istenilen ; sirada, cerceve icerisinde WCS'de yazar. Yazi yuksekligi ; 'TextSize, virgulden sonrki basamak sayisi 'Luprec ; sistem degiskenine baglidir** (defun c:cr (/ dc n0 nw n a1 a2 th el tx ty tz xy ls lt dz lc lm ln m1 m2 m3 ly p0 pz nl pt ax) (vl-load-com) (setq dc (vla-get-ActiveDocument (vlax-get-acad-object)) n0 '(0. 0.) nw n0 a1 (/ pi 2.) a2 (+ a1 pi) th (getvar 'TextSize) el (getvar 'Elevation) tz (/ th 2.) ty (* th 5.)) (initget 0 "XYZ XZY YXZ YZX ZXY ZYX") (if (not (setq xy (getkword "\nSorting type? [XYZ/XZY/YXZ/YZX/ZXY/ZYX] <YXZ>:"))) (setq xy "YXZ")) (while (setq lm nil ls nil lt nil n0 nw n 0 dz (getvar 'DimZin) p0 (getpoint "\nPoint:")) (vla-StartUndomark dc) (setvar 'DimZin 0) (setq p0 (trans p0 1 0) pz (caddr p0) lc (mapcar '(lambda(a) (rtos a 2 (getvar 'Luprec))) p0) ln (list (list "X" (car lc)) (list "Y" (cadr lc)) (list "Z" (caddr lc)))) (setvar 'DimZin dz) (repeat 3 (setq n (1+ n) lm (append lm (list (substr xy n 1))))) (mapcar '(lambda(a b) (setq ls (cons (vlax-ename->vla-object (entmakex (list '(0 . "Text") (cons 1 (strcat a ": " (cadr (nth (vl-position a (mapcar 'car ln)) ln)))) (cons 8 (strcat a " Coordinate")) (cons 10 (list tz (* tz b) pz)) (cons 40 th)))) ls))) lm (list 7. 4. 1.)) (foreach m ls (vla-GetBoundingBox m 'mn 'mx) (setq lt (cons (car (vlax-safearray->list mx)) lt))) (setq tx (+ tz (apply 'max lt)) m1 (list tx 0.) m2 (list tx ty) m3 (list 0. ty) ly '(8 . "Frame") ls (cons (vlax-ename->vla-object (entmakex (append (list '(0 . "LwPolyline") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") ly (cons 38 pz) '(90 . 4) '(70 . 1)) (mapcar '(lambda(a) (cons 10 a)) (list n0 m1 m2 m3))))) ls) nl (vlax-ename->vla-object (entmakex (list '(0 . "Line") ly (cons 10 p0) (cons 11 p0))))) (while (/= 3 (car (setq pt (grread T 1 0)))) (setq pt (cadr pt) ax (angle p0 pt)) (vlax-put nl 'EndPoint (list (car pt) (cadr pt) pz)) (setvar 'Elevation pz) (setq pt (mapcar '- pt (cond ((and (>= ax 0.) (< ax a1)) nw) ((and (>= ax a1) (< ax pi)) m1) ((and (>= ax pi) (< ax a2)) m2) ((and (>= ax a2) (< ax (* 2. pi))) m3)))) (foreach m ls (vla-TransformBy m (vlax-tmatrix (list (list 1 0 0 (- (car pt) (car n0))) (list 0 1 0 (- (cadr pt) (cadr n0))) '(0 0 1 0) '(0 0 0 1))))) (setq n0 pt)) (vla-EndUndomark dc) ) (setvar 'Elevation el) (prin1) )

> 1 <