Copyright © 2004-2022 SQL: 1.448 saniye - Sorgu: 114 - Ortalama: 0.0127 saniye
22.01.2024 15:35
brazor58 |
Bunu saygısızlık olarak algılamanız yersiz ve gereksiz bi duyar. Bu platformda sizlerin ve diğer arkadaşların ne kadar bu işe zaman harcadığının farkındayım zaten. Eğer zor ve zaman alıcı birşeyse zaten yazmaz kimse. burada 10 sayfa lisp yazılmış ama buradanda paylaşılmış. Herhangi ücret talep edilmeden. Eğer ücret karşılığında yaptıracaksam zaten bununla ilgili internette birsürü firmaylada rahatlıkla iletişime geçebilirim. Burada bir yardım talebinde bulunmak size saygısızlık olarak algılanıyor. Zorsa yapmak istemiyorsa zaten kimse kimseye bişey diyemez. Altını tekrardan çiziyorum böyle insanlara saygısızlık etmişim gibi gereksiz cümleleri kabul etmiyorum.
|
23.01.2024 06:06
ehya |
brazor58
Öncelikle emeğe saygı gösterelim dedim. Ücret istenmesinin nedenini söyledim. Kişisel saygısızlıktan bahsetmiyorum. Böyle bir durum olsa zaten konu devam edemezdi. Ücretli yazdırmak isteseniz de birsürü dediğiniz firmalara (hangi firmalar çok merak ediyorum) gidip bi fiyat alın. Yapılan işlemin basit olması kodunun da kısa olması gerektiğiniz göstermez. Her lispten ücret alınacak diye birşey yok. Bu kişilerin tercihi. Paylaşır yada paylaşmaz. Eğer bir kazanç olacak ise bu karşılıklı olmalı. Ücretsiz lispler bu sitede ve birçok platformda var. Yükleyin ve kullanın. Ancak genele hitap etmeyen ve sırf bu istek için siteye yeni üye olup ilk mesajında lisp isteyen kişinin isteğinin ücret karşılığında olacağını öğrendiğinde gösterdiği tepki de bizim açımızdan hiç hoş değil. Kabul edersiniz yada etmezsiniz. Tercih sizin..
|
23.01.2024 07:31
brazor58 |
Daha fazla laf kalabalıklığı yapıp uzatmak istemiyorum gerek yok. Yanlış anlaşıldıysam kusura bakmayın iyi günler .
|
01.03.2024 08:30
bayrecep |
İyi günler herkese. Şöyle bir lisp ihtiyacım var yardımcı olurmusunuz.
Çizimde yer alan block objeleri seçecek,seçtikten sonra patlatacak (explode) ve purge ile çizimi temizleyecek. Birçok çizim var tek tek uğraşmak ciddi zaman alıyor.
|
02.05.2024 09:50
semiyildiz |
merhabalar ,
kullandığım bir lisp var, yazıları multileader etikete çeviriyor, yalnız sağa ve sola doğru yazıyı hizalıyor ,lispi çalıştırdıktan sonra çizginin ortasına tıklıyorum ve ok buraya yerleşiyor sonra dikey eksene göre sol tarafa tıklarsam yazıyı sola doğru yapıştırıyor ,sağ tarafa doğru tıklarsam sağa doğru yapıştırıyor, benim ricam yukarı ve aşağı yönlendirecek şekilde de tıklama seçeneği ekleyebilir miyiz ? birde komutu başlatmak için her seferinde tekrar girmem gerekiyor ,otomatik tekrarlama yapabilirsek çok iyi olur, kod şu şekilde; Kod: (defun c:am (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth)
(vl-load-com) (defun rjp-getbbwdth (obj / out ll ur) (vla-getboundingbox obj 'll 'ur) (setq out (mapcar 'vlax-safearray->list (list ll ur))) (distance (car out) (list (caadr out) (cadar out))) ) (if (setq ss (ssget '((0 . "*TEXT")))) (progn (setq txt (apply 'strcat (mapcar 'cdr (vl-sort (mapcar '(lambda (x) (cons (vlax-get x 'insertionpoint) (strcat (vlax-get x 'textstring) " ") ) ) (setq ss (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) ) (function (lambda (y1 y2) (< (cadr (car y2)) (cadr (car y1)))) ) ) ) ) w (car (vl-sort (mapcar 'rjp-getbbwdth ss) '>)) txt (apply 'strcat (mapcar 'chr (reverse (cdr (reverse (vl-string->list txt))))) ) ) (mapcar 'vla-delete ss) ) ) (if (and (setq pt1 (getpoint "nSpecify leader arrowhead location: ")) (setq pt2 (getpoint pt1 "nSpecify landing location: ")) ) (progn (command "._MLEADER" pt1 pt2 "") (setq newleader (vlax-ename->vla-object (entlast))) (vla-put-textstring newleader txt) (vla-put-textwidth newleader w) ) ) (princ) ) ProhibiT (02.05.2024 10:05 GMT) |
02.05.2024 12:40
ufuk1245 |
Merhabalar,
2019 Autocadda çalışan lsp dosyası aşağıdaki detay yani 2025 autocadde çalışmıyor neden olabilir bu sorun bilgi verebilirseniz çok sevinirim teşekkürler, (defun C:BoMe(/ Boy Cap cp gbr Kbr KPNo kuk L MPo myerr Nk1 Nk2 olderr Rw YYuk) (defun myerr (errmsg) (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg))) (command "._undo" "_e") (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp)) (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo) (setq *error* olderr) (princ)) (setq olderr *error* *error* myerr) (*push-error-using-command*) (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (setq cp "") (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32 45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm")) (setq kuk (initget "Mm Cm mT """) gbr (getkword (strcat "\nÇizim Birimi [Mm/Cm/mT] <" egbr "> :"))) (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm")) (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale")))) (setq kuk (initget) YYuk (getreal (strcat "\nYazi yüksekligi <" (rtos eYuk) "> :"))) (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1)) (setq KPNo (getint (strcat "\nPoz Numarası <" (itoa eKPN) "> :"))) (if (not KPNo) (setq KPNo eKPN)) (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 1) (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook")) (setq Books (vlax-get-property ExApp "WorkBooks") Shts (vlax-get-property NwBook "Sheets") Sht1 (vlax-invoke-method Shts "Add")) (setq Books (vlax-get-property ExApp "WorkBooks") NwBook (vlax-invoke-method Books "Add") Shts (vlax-get-property NwBook "Sheets") Sht1 (vlax-get-property Shts "Item" 1))) (setq ExCLLs (vlax-get-property Sht1 "Cells")) (vlax-put-property ExApp "UseSystemSeparators" :vlax-false) (vlax-put-property ExApp "DecimalSeparator" ".") (vla-put-visible ExApp :vlax-true) (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2)) '((1 1 1 1) (1 2 1 2) (1 3 1 3)) '("Poz No." "Çap" "Boy")) (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 3))) 'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108)) (while (setq Nk1 (getpoint "\nBoru Başlangıç Noktasını seçiniz...")) (setq Nk2 (getpoint Nk1 "\n Boru Bitiş Noktasını seçiniz...") Boy (distance Nk1 Nk2) MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2)) (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk) (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo))) (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk)))) (princ "\nBoru Çap Yazısını seçiniz...") (while (not (setq Cap (ssget "+.:s" (list (cons 0 "*TEXT"))))) (princ "\n Sectiginiz obje bir Text veya MText olmalıdır!")) (cond ((= gbr "Mm") (setq Boy (/ Boy 1000))) ((= gbr "Cm") (setq Boy (/ Boy 100))) ((= gbr "m") (setq Boy Boy)) (T nil)) (setq Rw (1+ Rw) Cap (cdr (assoc 1 (entget (ssname Cap 0))))) (if (vl-string-position 45 Cap) (setq Cap (substr Cap (+ 2 (vl-string-position 45 Cap))))) (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2)) '(1 2 3) (list (itoa KPNo) Cap (rtos Boy 2 2))) (princ (strcat "\n* Poz No:" (itoa KPNo) ", Çap:" Cap ", Boy:" (rtos Boy 2 2))) (setq KPNo (1+ KPNo))) (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3)))) (vlax-put-property rn 'MergeCells :vlax-true) (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122 105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch))))) (vlax-put-property rn 'ShrinkToFit :vlax-true) (setq rn (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3)))) (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0")) (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1")) (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit) (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit) (vlax-put-property ExApp "UseSystemSeparators" :vlax-true) (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp)) (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo) (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))
|
09.05.2024 04:48
alisezgin |
Şeflerim merhaba ,
Ben elektrik mühendisiyim , işlerimizde linye iptalleri veya ilaveleri oluyor . Bu konu ile alakalı bir lisp isteğim olacak aradım bulamadım. Konusu textlerin içerisindeki sayısal değerden 1 ekleyecek veya 1 çıkaracak . yardımcı olursanız sevinirim saygılarımla. örnek resim; Linkleri görebilmek için ÜYE olmalısınız.
|
09.05.2024 08:50
ehya |
Alıntı Çıkarma işlemi için kod aşağıdadır.. (itoa (- (atoi kısmındaki - işaretini + yaparsanız toplama işlemi yapar. Buna göre lispi çoğaltabilirsiniz. Kod: (defun c:NE (/ ss tek acss )
(if (setq ss (ssget (list (cons 0 "TEXT")))) (progn (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-StartUndomark doc) (vlax-for tek (setq acss (vla-get-ActiveSelectionSet doc)) (vla-put-textstring tek (strcat (substr (vla-get-textstring tek) 1 1) (itoa (- (atoi (substr (vla-get-textstring tek) 2))1)) ))) (vla-endUndomark doc) )) (princ))
|
10.05.2024 11:43
ufuk1245 |
Hocam rahatsız ediyorum kusura bakmayın lütfen daha önce 2013 autocadde çalışan LSP dosyaları vardı bende kullanabiliyordum ancak şuan 2024 veya başka hiçbir autocadde VL OBJECT NİL hatası veriyor lsp yazılımı şu şekilde; Sorunu nasıl çözebilirim acaba yardımcı olabilirseniz sevinirim Teşekkürler,
(defun C:KaMe (/ Ayrc b bhb Books Boy cp Ebat ExApp ExCLLs gbr h Kbr KPNo kuk L MPo myerr n1 n2 Nk1 Nk2 NwBook olderr p1 p2 rn Rw Sht1 Shts SLn Thc Yer YYer YYuk) (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (defun myerr (errmsg) (if (/= errmsg "nFunction cancelled") (prompt (strcat "n" errmsg))) (command-s "._undo" "_e") (setq error olderr) (princ)) (setq olderr error error myerr) (setq cp "") (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32 45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm")) (setq kuk (initget "Mm Cm mT """) gbr (getkword (strcat "nÇizim Birimi [Mm/Cm/mT] <" egbr "> :"))) (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm")) (setq kuk (initget "Mm Cm mT """) Kbr (getkword (strcat "nKanal Ebadı Birimi [Mm/Cm/mT] <" eKbr "> :"))) (if (not Kbr) (setq Kbr eKbr)) (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale")))) (setq kuk (initget) YYuk (getreal (strcat "nYazi yüksekligi <" (rtos eYuk) "> :"))) (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1)) (setq KPNo (getint (strcat "nKanal Poz Numarası <" (itoa eKPN) "> :"))) (if (not KPNo) (setq KPNo eKPN)) (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 2) (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook")) (setq Books (vlax-get-property ExApp "WorkBooks") Shts (vlax-get-property NwBook "Sheets") Sht1 (vlax-invoke-method Shts "Add")) (setq Books (vlax-get-property ExApp "WorkBooks") NwBook (vlax-invoke-method Books "Add") Shts (vlax-get-property NwBook "Sheets") Sht1 (vlax-get-property Shts "Item" 1))) (setq ExCLLs (vlax-get-property Sht1 "Cells")) (vlax-put-property ExApp "UseSystemSeparators" :vlax-false) (vlax-put-property ExApp "DecimalSeparator" ".") (vla-put-visible ExApp :vlax-true) (mapcar '(lambda (p1 p2) (vlax-put-property (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item (nth 0 p1) (nth 1 p1))) (vlax-variant-value (vlax-get-property ExCLLs 'Item (nth 2 p1) (nth 3 p1)))) 'MergeCells :vlax-true) (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2)) '((1 1 2 1) (1 2 1 3) (2 2 2 2) (2 3 2 3) (1 4 2 4) (1 5 2 5) (1 6 2 6)) (list "Poz No." "Kanal Ebadı" (strcat "Genişlikn(" (strcase Kbr T) ")") (strcat "Yükseklikn(" (strcase Kbr T) ")") "Kanal Boyun(m)" "Alann(m²)" "Sac Kalınlığın(mm)")) (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item 2 6))) 'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108)) (while (setq Nk1 (getpoint "nKanal Başlangıç Noktasını seçiniz...")) (setq Nk2 (getpoint Nk1 "n Kanal Bitiş Noktasını seçiniz...") Boy (distance Nk1 Nk2) MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2)) (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk) (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo))) (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk)))) (if (= Ebat0 nil) (setq Ebat0 "200*400")) (setq Ebat (getstring (strcat "nKanal Ebadını Giriniz <" Ebat0 ">: "))) (if (= Ebat "") (setq Ebat Ebat0) (setq Ebat0 Ebat)) (setq Ayrc nil Ebat (if (or (wcmatch Ebat "Ø*") (wcmatch Ebat "ø*")) (substr Ebat 2) (if (wcmatch Ebat "%%C*") (substr Ebat 4) Ebat)) L (strlen Ebat)) (while (> (setq L (1- L)) 0) (if (or (< (ascii (substr Ebat L 1)) 48)(> (ascii (substr Ebat L 1)) 57)) (setq Ayrc (ascii (substr Ebat L 1))))) (if Ayrc (setq yer (vl-string-position Ayrc Ebat) b (atof (substr Ebat 1 yer)) h (atof (substr Ebat (+ yer 2))) bhb (if (> b h) b h)) (setq b (atof Ebat) h 0 bhb b)) (cond ((= Kbr "Mm") (setq b (/ b 1000) h (/ h 1000))) ((= Kbr "Cm") (setq b (/ b 100) h (/ h 100) bhb (* bhb 10))) ((= Kbr "mT") (setq b b h h bhb (* bhb 1000))) (T nil)) (cond ((= gbr "Mm") (setq Boy (/ Boy 1000))) ((= gbr "Cm") (setq Boy (/ Boy 100))) (T nil)) (setq Thc (cond ((<= bhb 249) 0.5) ((and (> bhb 249) (<= bhb 499)) 0.6) ((and (> bhb 499) (<= bhb 989)) 0.75) ((and (> bhb 989) (<= bhb 1989)) 0.90) ((and (> bhb 1989) (<= bhb 2489)) 1.15) ((>= bhb 2490) 1.2)) SLn (if (zerop h) (* pi b Boy) (* (* (+ b h) 2.0) Boy)) Rw (1+ Rw)) (cond ((= Kbr "Mm") (setq b (* b 1000) h (* h 1000))) ((= Kbr "Cm") (setq b (* b 100) h (* h 100)))) (if (zerop h) (setq b (strcat "Ø" (rtos b)) h "-")) (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2)) '(1 2 3 4 5 6) (list (itoa KPNo) (if (= (type b) 'STR) b (rtos b)) (if (= (type h) 'STR) h (rtos h)) (rtos Boy 2 2) (rtos SLn 2 2) (rtos Thc 2 2))) (princ (strcat "n* Poz No:" (itoa KPNo) ", Kanal Ebadı:" (if (= h "-") (strcat "Ø" Ebat) Ebat) ", Kanal Uzunluğu:" (rtos Boy 2 2) ", Sac Alanı:" (rtos SLn 2 2) ", Sac Kalınlığı:" (rtos Thc))) (setq KPNo (1+ KPNo))) (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 6)))) (vlax-put-property rn 'MergeCells :vlax-true) (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122 105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch))))) (vlax-put-property rn 'ShrinkToFit :vlax-true) (setq rn (vlax-get-property ExCLLs "Range" (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1)) (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 6)))) (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0")) (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1")) (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit) (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit) (vlax-put-property ExApp "UseSystemSeparators" :vlax-true) (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp)) (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo) (command "_.undo" "end") (setq error olderr) (prin1))
|
11.05.2024 08:40
mesuttasar |
Alıntı Merhaba, polyline veya line üzerine istenilen mesafede km yazan lisp kodu aşağıdadır. Kod: (defun c:ky(/ eks eksdata plset mes obj lenobj dgr km mes angle1 pt1 pt2)
(setq eks (car (entsel "\n Ekseni seciniz..:"))) (setq eksdata (entget eks)) (setq mes (getint "\nAra mesafeyi giriniz..:")) (vl-load-com) (setq obj (vlax-ename->vla-object eks)) (setq lenobj (vlax-get-property obj 'length)) (setq dgr 0) (setq km 0) (while (> lenobj km) (setq km (+ dgr mes)) (setq pt (vlax-curve-getpointAtDist obj km)) (setq pt1 (vlax-curve-getpointAtDist obj (- km 0.01))) ;Bir önceki nokta (setq pt2 (vlax-curve-getpointAtDist obj (+ km 0.01))) ;Bir sonraki nokta (setq angle1 (angle pt1 pt2)) ;İki nokta arasındaki açiyi hesapla (setq angle1 (+ angle1 (/ pi 2.0))) (entmake (list (cons 0 "text") (cons 10 pt) (cons 40 1) (cons 1 (itoa km)) (cons 50 angle1))) (entmake (list (cons 0 "point") (cons 10 pt) (cons 8 "0"))) (setq dgr km) );while );end mesuttasar (11.05.2024 09:24 GMT) |
21.05.2024 07:15
alisezgin |
Alıntı Örnek gösterdiğime göre lispiniz çalışıyor , teşekkür ederim ehya şef. Peki bunu uzun textlerde kullanabilmem için bi yolu var mıdır? Linkleri görebilmek için ÜYE olmalısınız.
|
22.07.2024 08:45
umittaser |
Alıntı (defun C:LP(/ PNT1 P1X P1Y STDY STDX STDZ COORDN COORDE PTXT) (setq PNT1 (getpoint "nNoktayý iþaretleyiniz: ")) (setq P1X (car pnt1)) (setq P1Y (cadr pnt1)) (setq P1Z (caddr pnt1)) (setq STDX (rtos P1X 2 3)) (setq STDY (rtos P1Y 2 3)) (setq STDZ (rtos P1Z 2 3)) (setq COORDE (strcat "Y="STDX)) (setq COORDN (strcat "X="STDY)) (setq COORDZ (strcat "Z="STDz)) (setq PTXT (getpoint "nYazýnýn yazýlacaðý yeri iþaretleyiniz: ")) (command "LEADER" PNT1 PTXT ""COORDN COORDE "")) (Princ "Komutu çalýþtýrmk için [LP] yazýnýz!") (PRINC " --> 'www.autocadokulu.com' Çizim yardýmlarý yüklendi !")
|
24.07.2024 00:35
ahmetkocer |
Merhaba. Polyline ile çizilmiş çokgenlerin içinde yer alan metinleri seçme eklentisine ihtiyacım var. Çokgeni seçip komutu girince içindeki metini seçecek. Saatlerdir uğraşıyorum ama AutoCad2025de çalışmadı. Point inside, too many actual parameters, Boundingbox vs hatalar aldım. Farklı farklı yöntemler denememe rağmen farklı hatalar aldım. Olmadı. Yardımcı olabilir misiniz?
|
24.07.2024 06:43
ehya |
Alıntı Kod: (defun c:YSEC (/ ss c say secim tek lst y-say)
(if (setq ss (ssget (list (cons 0 "LWPOLYLINE")))) (progn (setq c -1 say (sslength ss) secim (ssadd)) (while (< (setq c (1+ c))say) (setq tek (ssname ss c) lst (mapcar 'cdr (vl-remove-if '(lambda (x)(/= (car x) 10)) (entget tek)))) (if (setq sec (ssget "_wp" lst '((0 . "TEXT")))) (progn (setq y-say (sslength sec) cc -1) (while (< (setq cc (1+ cc)) y-say) (ssadd (ssname sec cc) secim))))) (sssetfirst nil secim)))(princ))
|
13.08.2024 11:32
atiemre |
Merhabalar,
Bir dwg dosyam var ve içerisinde antetli şekilde bir çok çizim planı mevcut. Antetli çizimler blok değiller. Benim yapmak istediğim, sectiğim objeleri blok yapması ve blok isminide seçeceğim textteki içerik yapması. Daha sonra bu bloklarıda bir klasör içinde ayrı dwgler olarak kaydetmek istiyorum. Bu konuda yardımcı olabilir misiniz?
|
28.09.2024 14:01
baha07 |
Alıntı unutmayinki text iceri ayni ise blok isminide ayni yapmaya calisacaktir ve lisp hata verecektir . ya text iceriklerini degistireceksiniz yada RBK kodu ile onceki blocklarin ismini degistirmeniz gerekiyor . yada blok olusturan lispindeki bu satir grubunu bununla Kod: ; Get Block Name and Base Point (while (or (not bn) (not (snvalid bn)) ) ;_ end or (setq bn (getstring "Specify Block Name: ")) ) ;_ end while ; (initget 1) (setq pt '(0 0)) ;(getpoint "Specify Base Point for Block: ")) ;;; Create BLOCK Header degistirip block isimlerini manuel gireceksiniz Kod: ;********************************** ; Rename block name ; (block isminin degistirilmesi) ; ; powered by yazgunesi ; www.autocadokulu.com ; ; ********************************* (defun c:rbk (/ blksecimi blkname blknew) ; select block to view name (setq blksecimi (entget(car(entsel "Select block to view NAMES : "))) blkname (cdr(assoc 2 blksecimi)) ) (princ (strcat ">>> " (cdr (assoc 2 blksecimi)) " <<<" )) ; princ block name (setq blknew (getstring t "\nEnter new block name: ")) (command "_.rename" "_block" blkname blknew) (prompt "\nBlock ismi basariyla degistirilmistir...") (princ) ) Kod: ; secilen nesneleri istenen uygulama noktasini kullanarak tek blok yapar ; blok ismini secilen text iceri olarak yapar ; orjinal nesnelerin silinmesini istiyorsaniz ;(command "_.ERASE" ss "") asagida bulunan bu satirin onundeki " ; " simgesini silin ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/a-lisp-routine-to-create-a-block-from-selected-objectes-and/td-p/11026565 (defun c:obj2blk1 (/ ss bn pt i ent elist) ; Get Entities (while (not ss) (princ "\nSelect Objects to Convert to Blocks:") (setq ss (ssget '((-4 . "<NOT") (0 . "INSERT,POLYLINE,VIEWPORT") (-4 . "NOT>")))) ) ;_ end while ; Get Block Name and Base Point (while (or (not bn) (not (snvalid bn)) ) ;_ end or (setq entt (car (entsel "\nSelect source text:"))) (setq enttx (entget entt)) (setq bn (cdr (assoc 1 enttx))) ) ;_ end while (initget 1) (setq pt (getpoint "Specify Base Point for Block: ")) ;;; Create BLOCK Header (entmake (list (cons 0 "BLOCK") (cons 10 pt) (cons 2 bn) (cons 70 0))) ;;;STEP THRU THE SET (setq i (sslength ss)) (while (>= i (setq i (1- i)) 0) (setq ent (ssname ss i) elist (entget ent) ) ;_ end setq (entmake elist) ) ;_ end while ;;;FINISH THE BLOCK DEFINITION (entmake (list (cons 0 "ENDBLK") (cons 8 "0"))) ;;;Insert the Block & Delete Originals (entmake (list (cons 0 "INSERT") (cons 2 bn) (cons 8 "0") (cons 10 pt))) ;(command "_.ERASE" ss "") (redraw) (prin1) ) ;_ end defun Kod: ; ---------------------------------------------------------------------- ; Bloklari , blok ismiyle tek tek dwg`lere ayirir ; ; ---------------------------------------------------------------------- ; ; ---------------------------------------------------------------------- (defun c:wba () (setq cmdecho (getvar "CMDECHO")) (setvar "CMDECHO" 0) ; (defun LM:browseforfolder ( msg dir bit / err fld pth shl slf ) (setq err (vl-catch-all-apply (function (lambda ( / app hwd ) (if (setq app (vlax-get-acad-object) shl (vla-getinterfaceobject app "shell.application") hwd (vl-catch-all-apply 'vla-get-hwnd (list app)) fld (vlax-invoke-method shl 'browseforfolder (if (vl-catch-all-error-p hwd) 0 hwd) msg bit dir) ) (setq slf (vlax-get-property fld 'self) pth (vlax-get-property slf 'path) pth (vl-string-right-trim "" (vl-string-translate "/" "" pth)) )))))) (if slf (vlax-release-object slf)) (if fld (vlax-release-object fld)) (if shl (vlax-release-object shl)) (if (vl-catch-all-error-p err) (prompt (vl-catch-all-error-message err)) pth )) (setq path (LM:browseforfolder "Klasor secin" nil 0)) (if (/= path nil) (progn (if (= (substr path (strlen path) 1) "") (setq path (substr path 1 (1- (strlen path)))) ) (princ "\nDS> Building List of Blocks ... ") (setq lst nil) (setq itm (tblnext "BLOCK" T)) (while (/= itm nil) (setq nam (cdr (assoc 2 itm))) (setq pass T) (if (/= (cdr (assoc 1 itm)) nil) (setq pass nil) (progn (setq ctr 1) (repeat (strlen nam) (setq chk (substr nam ctr 1)) (if (or (= chk "*")(= chk "|")) (setq pass nil) ) (setq ctr (1+ ctr)) ) ) ) (if (= pass T) (setq lst (cons nam lst)) ) (setq itm (tblnext "BLOCK")) ) (setq lst (acad_strlsort lst)) (princ "Done.") ; (foreach blk lst (setq fn (strcat path (chr 92) blk)) (if (findfile (strcat fn ".dwg")) (command "_.WBLOCK" fn "_Y" blk) (command "_.WBLOCK" fn blk) ) ) ) ) ; (setvar "CMDECHO" cmdecho) (princ) ) (PRINC " Lispi calistirmak icin komut satirina 'WBA' yaziniz ") Kod: ;****Secilen nesneleri olusturulan klasore orjinal koordinatinda ; WBlock olarak tek tek save eder..**** (defun c:WBblock (/ dc sl n ss dr i ns) (vl-load-com) (if (and (setq dc (vla-get-ActiveDocument (vlax-get-acad-object)) sl (vla-get-SelectionSets dc) n 0 ss (ssget)) (setq dr (getfiled "WBlock" "" "" 9))) (progn (vl-mkdir dr) (repeat (setq i (sslength ss)) (setq i (1- i) ns (vla-Add sl "S") n (1+ n)) (vlax-invoke ns 'AddItems (list (vlax-ename->vla-object (ssname ss i)))) (vla-WBlock dc (strcat dr "/" (itoa n) ".dwg") (vla-Item sl "S")) (vla-Delete ns) ) ) ) (prin1) ) Kod: ;; tek tek ayrilan bloklari(wba) bir dwg icine toplar
;; Block Import Lisp 08/12/2008 ;; CAB at TheSwamp.org ;; Get user selection of folder ;; Get all DWG files in folder ;; INSERT dwg as block @ 0,0 ;; get Bounding Box of block ;; Move Insert to right w/ gap between blocks ;; Next Insert (defun c:BI (/ path LastDist gap space err newblk bname obj ll lr ur InsPt dist GetFolder) (vl-load-com) (defun GetFolder ( / DirPat msg) (setq msg "Open a folder and click on SAVE") (and (setq DirPat (getfiled "Browse for folder" msg " " 1)) (setq DirPat (substr DirPat 1 (- (strlen DirPat) (strlen msg)))) ) DirPat ) (defun activespace (doc) (if (or (= acmodelspace (vla-get-activespace doc)) (= :vlax-true (vla-get-mspace doc))) (vla-get-modelspace doc) (vla-get-paperspace doc) ) ) (setq gap 5) ; this is the gap between blocks (setq LastDist 0.0) ; this is the cumulative distance (if (setq Path (GetFolder)) (progn (setq space (activespace (vla-get-activeDocument (vlax-get-acad-object)))) (prompt "\n*** Working, Please wait ......\n") (foreach bname (vl-directory-files Path "*.dwg" 1) ;; OK, try & insert the Block (if (vl-catch-all-error-p (setq err (vl-catch-all-apply '(lambda () (setq newblk (vla-insertBlock space (vlax-3d-point '(0.0 0.0 0.0)) (strcat path bname) 1.0 1.0 1.0 0.0)) )))) ;; Display the error message and block/file name (prompt (strcat "\n" bname " " (vl-catch-all-error-message err))) ;; ELSE (progn ; INSERT was sucessful, move the block ;; get bounding box (if (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vla-getboundingbox (list newblk 'll 'ur)))) (prompt (strcat "\nBB Error - could not move " bname "\n " (vl-catch-all-error-message err))) (progn (setq ll (vlax-safearray->list ll) ur (vlax-safearray->list ur) lr (list (car ur) (cadr ll)) dist (distance ll lr) ) ;; MOVE the block (setq ;InsPt (vla-get-insertionpoint Newblk) NewPt (polar '(0. 0. 0.) 0.0 (+ LastDist Gap (* dist 0.5))) LastDist (+ LastDist Gap dist) ) (vlax-put Newblk 'insertionpoint NewPt) ) ) ) ) ) ) ) (princ) ) (princ) (prompt "\nBlock Import Loadd, Enter Bi to run.") baha07 (28.09.2024 14:29 GMT) |
01.10.2024 19:44
idrisgoker |
Merhabalar hocalarım,
Belirteceğim text dosyası içerisindeki metinleri bulup bulunduğu yerde yuvarlak oluşturan bir lisp oluşturmayı başardım lakin projedeki bulduğu metnin base noktasına" hatch pick point" gibi kabul edip hatch oluşturmasına ihtiyacım var. Özetleyecek olursam text dosyamdaki mahal adlarını bulup bulunduğu mahalde hatch oluşturmasını istiyorum. Mahalleri solid veya herhangi bir formda hatch yapabilir. Geldiğim son noktayı paylaşmak istiyorum. (defun c:FindAndMarkText ( / file textList text ss ent entData textPos textHeight) ;; Dosya seçimini kullanıcıya bırak (setq file (getfiled "Metin dosyasını seçin" "" "txt" 4)) (if file (progn (setq file (open file "r")) (if file (progn (setq textList '()) (while (setq text (read-line file)) (setq textList (cons text textList)) ) (close file) ;; Metinleri ara ve işaretle (foreach txt textList (setq ss (ssget "X" (list (cons 1 txt)))) (if ss (progn (repeat (sslength ss) (setq ent (ssname ss 0)) (setq entData (entget ent)) (setq textPos (cdr (assoc 10 entData))) (setq textHeight (cdr (assoc 40 entData))) ;; Metin yüksekliğini al ;; Çember çiz (command "CIRCLE" textPos (* textHeight 0.5)) ;; Çapı metin yüksekliğine göre ayarla (ssdel ent ss) ) ) ) ) ) (princ "\nDosya açılamadı. Lütfen dosya yolunu kontrol edin.") ) ) (princ "\nDosya seçilmedi.") ) (princ) ) Şimdiden teşekkür ederim. idrisgoker (01.10.2024 19:54 GMT) |
02.10.2024 06:24
ehya |
Alıntı
|
02.10.2024 08:49
idrisgoker |
Alıntı
|
baha07 |
merhabalar
elimde iki text arasindaki farki cikarip aradaki farki istedigim yere ekranda text olarak yazdiran bir lisp var . isimi goruyor . sormak istedigim bu farki yeni text olarak yazdirirken ,bazi calistigim projelerde text yuksekligini farkli yapiyor . bu fark hangi ayardan kaynaklaniyor buladim . hangi ayar oldugu konusunda bana yardimci olabilecek var mi ? ornek dosyalari ekledim Kod: ; secilen textler arasinda 4 islem yapip ekrana yeni text olarak yazdirir ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-subtract-2-given-mtexts/td-p/5131450 (defun c:AV (/) (c:CombineValues)) (defun c:CombineValues (/ *error* AT:ExtractNumbers AT:Str2Lst AT:MText AT:Entsel AT:ListSelect CV:StripFormat _sel dZin f i obj num nStr final pt ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; error handler (defun *error* (msg) (and dZin (setvar 'dimzin dZin)) (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*")) (princ (strcat "\nError: " msg)) ) ) ;;; Extract numbers from string ;;; #String - String to extract numbers from ;;; Required Subroutines: AT:Str2Lst ;;; Alan J. Thompson, 11.13.09 / 04.08.10 (defun AT:ExtractNumbers (Str / i l) (setq i -1) (mapcar (function atof) (AT:Str2Lst (vl-list->string (mapcar (function (lambda (x) (setq i (1+ i)) (cond ;; number ((< 47 x 58) x) ;; - and number following ((and (eq x 45) (< 47 (nth (1+ i) l) 58)) x) ;; . and follows a number ((and (eq x 46) (not (minusp (1- i))) (< 47 (nth (1- i) l) 58)) x) (t 32) ) ) ) (setq l (vl-string->list (vl-princ-to-string Str))) ) ) " " ) ) ) ;;; Convert string to list, based on separator ;;; #Str - String to convert ;;; #Sep - Separator to break string into items ;;; Ex. - (AT:Str2Lst "1,2,3" ",") -> '("1" "2" "3") ;;; Alan J. Thompson, 11.11.09 (defun AT:Str2Lst (#Str #Sep / #Inc #List #Str) (while (setq #Inc (vl-string-search #Sep #Str)) (setq #List (cons (substr #Str 1 #Inc) #List)) (setq #Str (substr #Str (+ 2 #Inc))) ) ;_ while (vl-remove "" (append (reverse #List) (list #Str))) ) ;_ defun ;;; Add MText to drawing ;;; Pt - MText insertion point ;;; Str - String to place in created MText object ;;; Wd - Width of MText object (if nil, will be 0 width) ;;; Lay - Layer to place Mtext object on (nil for current) ;;; Jus - Justification # for Mtext object ;;; 1 or nil= TopLeft ;;; 2= TopCenter ;;; 3= TopRight ;;; 4= MiddleLeft ;;; 5= MiddleCenter ;;; 6= MiddleRight ;;; 7= BottomLeft ;;; 8= BottomCenter ;;; 9= BottomRight ;;; Alan J. Thompson, 05.23.09 / 04.09.10 (defun AT:MText (Pt Str Wd Lay Jus / Wd s o) (or Wd (setq Wd 0.)) (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) (setq s (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*)) (eq :vlax-true (vla-get-mspace *AcadDoc*)) ) (vla-get-modelspace *AcadDoc*) (vla-get-paperspace *AcadDoc*) ) Pt (cond ((vl-consp Pt) (vlax-3d-point Pt)) ((eq (type Pt) 'variant) Pt) ) ) (vla-put-lock (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))) :vlax-false) (setq o (vla-addMText s Pt Wd (vl-princ-to-string Str))) (and Lay (tblsearch "layer" Lay) (vla-put-layer o Lay)) (cond ((vl-position Jus '(1 2 3 4 5 6 7 8 9)) (vla-put-AttachmentPoint o Jus) (vla-put-InsertionPoint o Pt) ) ) o ) ;;; Entsel or NEntsel with options ;;; #Nested - Entsel or Nentsel (T for Nentsel, nil for Entsel) ;;; #Message - Selection message (if nil, "\nSelect object: " is used) ;;; #FilterList - DXF ssget style filtering (nil if not required) ;;; "V" as first item in list to convert object to VLA-OBJECT (must be in list if no DXF filtering) ;;; "L" as first item in list to ignore locked layers (must be in list if no DXF filtering) ;;; #Keywords - Keywords to match instead of object selection (nil if not required) ;;; Example: (AT:Entsel nil "\nSelect MText not on 0 layer [Settings]: " '("LV" (0 . "MTEXT")(8 . "~0")) "Settings") ;;; Example: (AT:Entsel T "\nSelect object [Settings]: " '("LV") "Settings") ;;; Alan J. Thompson, 04.16.09 ;;; Updated: Alan J. Thompson, 06.04.09 (changed filter coding to work as ssget style dxf filtering) ;;; Updated: Alan J. Thompson, 09.07.09 (added option to ignore locked layers and convert object to VLA-OBJECT ;;; Updated: Alan J. Thompson, 09.18.09 (fixed 'missed pick' alert) (defun AT:Entsel (#Nested #Message #FilterList #Keywords / #Count #Message #Choice #Ent #VLA&Locked #FilterList ) (vl-load-com) (setvar "errno" 0) (setq #Count 0) ;; fix message (or #Message (setq #Message "\nSelect object: ")) ;; set entsel/nentsel (if #Nested (setq #Choice nentsel) (setq #Choice entsel) ) ;_ if ;; check if option to convert to vla-object or ignore locked layers in #FilterList variable (and (vl-consp #FilterList) (eq (type (car #FilterList)) 'STR) (setq #VLA&Locked (car #FilterList) #FilterList (cdr #FilterList) ) ;_ setq ) ;_ and ;; select object (while (and (not #Ent) (/= (getvar "errno") 52)) ;; if keywords (and #Keywords (initget #Keywords)) (cond ((setq #Ent (#Choice #Message)) ;; if ignore locked layers (and #VLA&Locked (vl-consp #Ent) (wcmatch (strcase #VLA&Locked) "*L*") (not (zerop (cdr (assoc 70 (entget (tblobjname "layer" (cdr (assoc 8 (entget (car #Ent))))) ;_ tblobjname ) ;_ entget ) ;_ assoc ) ;_ cdr ) ;_ zerop ) ;_ not (setq #Ent nil #Flag T ) ;_ setq ) ;_ and ;; #FilterList check (if (and #FilterList (vl-consp #Ent)) ;; process filtering from #FilterList (or (not (member nil (mapcar '(lambda (x) (wcmatch (strcase (vl-princ-to-string (cdr (assoc (car x) (entget (car #Ent))))) ;_ vl-princ-to-string ) ;_ strcase (strcase (vl-princ-to-string (cdr x))) ) ;_ wcmatch ) ;_ lambda #FilterList ) ;_ mapcar ) ;_ member ) ;_ not (setq #Ent nil #Flag T ) ;_ setq ) ;_ or ) ;_ if ) ) ;_ cond (and (or (= (getvar "errno") 7) #Flag) (/= (getvar "errno") 52) (not #Ent) (setq #Count (1+ #Count)) (prompt (strcat "\nNope, keep trying! " (itoa #Count) " missed pick(s).") ;_ strcat ) ;_ prompt ) ;_ and ) ;_ while (if (and (vl-consp #Ent) #VLA&Locked (wcmatch (strcase #VLA&Locked) "*V*")) ;_ and (vlax-ename->vla-object (car #Ent)) #Ent ) ;_ if ) ;_ defun ;list select dialog ;create a temp DCL multi-select list dialog from provided list ;value is returned in list form, DCL file is deleted when finished ;example: (setq the_list (AT:listselect "This is my list title" "Select items to make a list" "25" "30" "true" (list "object 1" "object 2" "object 3")) ;if mytitle is longer than defined width, the width will be ignored and it will fit to title string ;if mylabel is longer than defined width, mylabel will be truncated ;myheight and mywidth must be strings, not numbers ;mymultiselect must either be "true" or "false" (true for multi, false for single) ;created by: alan thompson, 9.23.08 ;some coding borrowed from http://www.jefferypsanders.com (thanks for the DCL examples) (defun AT:ListSelect (mytitle ;title for dialog box mylabel ;label right above list box myheight ;height of dialog box !!*MUST BE STRING*!! mywidth ;width of dialog box !!*MUST BE STRING*!! mymultiselect ;"true" for multiselect, "false" for single select mylist ;list to display in list box / retlist readlist count item savevars fn fo valuestr dcl_id ) (defun saveVars (/ readlist count item) (setq retList (list)) (setq readlist (get_tile "mylist")) (setq count 1) (while (setq item (read readlist)) (setq retlist (append retList (list (nth item myList)))) (while (and (/= " " (substr readlist count 1)) (/= "" (substr readlist count 1)) ) (setq count (1+ count)) ) (setq readlist (substr readlist count)) ) ) ;defun (setq fn (vl-filename-mktemp "" "" ".dcl")) (setq fo (open fn "w")) (setq valuestr (strcat "value = "" mytitle "";")) (write-line (strcat "list_select : dialog { label = "" mytitle "";") fo) (write-line (strcat " : column { : row { : boxed_column { : list_box { label ="" mylabel ""; key = "mylist"; allow_accept = true; height = " myheight "; width = " mywidth "; multiple_select = " mymultiselect "; fixed_width_font = false; value = "0"; } } } : row { : boxed_row { : button { key = "accept"; label = " Okay "; is_default = true; } : button { key = "cancel"; label = " Cancel "; is_default = false; is_cancel = true; } } } } }" ) fo ) (close fo) (setq dcl_id (load_dialog fn)) (new_dialog "list_select" dcl_id) (start_list "mylist" 3) (mapcar 'add_list myList) (end_list) (action_tile "cancel" "(setq ddiag 1)(done_dialog)") (action_tile "accept" "(setq ddiag 2)(saveVars)(done_dialog)") (start_dialog) (if (= ddiag 1) (setq retlist nil) ) (unload_dialog dcl_id) (vl-file-delete fn) retlist ) ;defun ;; StripFormat as taken (with permission) from the following: ;; StripMtext Version 5.0b for AutoCAD 2000 and above ;; Copyright© Steve Doman and Joe Burke 2010 ;; Location: http://www.theswamp.org/index.php?topic=31584.0 ;; Arguments: ;; str - an mtext string. ;; formats - a list of format code strings or a string. ;; Format code arguments are not case sensitive. ;; Examples: ;; Remove Font, Overline and Underline formatting. ;; (StripFormat <mtext string> (list "f" "O" "U")) ;; Or a quoted list: ;; (StripFormat <mtext string> '("f" "O" "U")) ;; Or a string: ;; (StripFormat <mtext string> "fOU") ;; Remove all formatting except Overline and Underline. ;; (StripFormat <mtext string> (list "*" "^O" "^U")) ;; Or a quoted list: ;; (StripFormat <mtext string> '("*" "^O" "^U")) ;; Or a string: ;; (StripFormat <mtext string> "*^O^U") ;; Available codes: ;; A (^A) - Alignment ;; B (^B) - taBs ;; C (^C) - Color ;; F (^F) - Font ;; H (^H) - Height ;; L (^L) - Linefeed (newline, line break, carriage return) ;; O (^O) - Overline ;; Q (^Q) - obliQuing ;; P (^P) - Paragraph (embedded justification, line spacing and indents) ;; S (^S) - Stacking ;; T (^T) - Tracking ;; U (^U) - Underline ;; W (^W) - Width ;; ~ (^~) - non-breaking space ;; * - all formats (defun CV:StripFormat (str formats / FormatsToList text slashflag lbrace rbrace RE:Replace RE:Execute Alignment Tab Color Font Height Linefeed Overline Paragraph Oblique Stacking Tracking Underline Width Braces HardSpace ) ;; Argument: either a list of strings or a string. ;; Given a list, ensure formats are uppercase. ;; Given a formats string, convert it to a list of uppercase strings. ;; Examples: (FormatsToList "fOU") > ("F" "O" "U") ;; (FormatsToList "f^OU") > ("F" "^O" "U") (defun FormatsToList (arg / lst) (cond ((= (type arg) 'LIST) (mapcar 'strcase arg)) ((= (type arg) 'STR) (while (not (eq "" (substr arg 1))) (if (eq "^" (substr arg 1 1)) (setq lst (cons (strcat "^" (substr arg 2 1)) lst) arg (substr arg 3) ) (setq lst (cons (substr arg 1 1) lst) arg (substr arg 2) ) ) ) (mapcar 'strcase (reverse lst)) ) ) ) ; end FormatsToList (setq formats (FormatsToList formats)) ;; Access the RegExp object from the blackboard. ;; Thanks to Steve for this idea. (or (vl-bb-ref '*REX*) (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp"))) (defun RE:Replace (newstr pat string) (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) (vlax-put (vl-bb-ref '*REX*) 'Global actrue) (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr) ) ;end (defun RE:Execute (pat string / result match idx lst) (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) (vlax-put (vl-bb-ref '*REX*) 'Global actrue) (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string)) (vlax-for x result (setq match (vlax-get x 'Value) idx (vlax-get x 'FirstIndex) ;; position within string - zero based - first position is zero lst (cons (list match idx) lst) ) ) lst ) ;end ;; Replace linefeeds using this format "\n" with the AutoCAD ;; standard format "\P". The "\n" format occurs when text is ;; copied to ACAD from some other application. (setq str (RE:Replace "\\P" "\\n" str)) ;;;;; Start remove formatting sub-functions ;;;;; ;; A format (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str)) ;; B format (tabs) (defun Tab (str / lst origstr tempstr) (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str)) (foreach x lst (setq origstr (car x) tempstr (RE:Replace "" "\\t" origstr) str (vl-string-subst tempstr origstr str) ) ) (RE:Replace " " "\\t" str) ) ;; C format (defun Color (str) ;; True color and color book integers are preceded ;; by a lower case "c". Standard colors use upper case "C". (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str) ) ;; F format (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str)) ;; H format (defun Height (str) (RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str) ;; This also works, but it's not as clear as the above. ;; (RE:Replace "" "\\\\H\\d\\.?\\d*x;" str) ) ;; L format ;; Leading linefeeds are not converted to spaces. (defun Linefeed (str / teststr) ;; Remove formatting from test string other than linefeeds. ;; Seems there's no need to check for stacking ;; because a linefeed will always come before stack formatting. (setq teststr (Alignment str) teststr (Color teststr) teststr (Font teststr) teststr (Height teststr) teststr (Overline teststr) teststr (Paragraph teststr) teststr (Oblique teststr) teststr (Tracking teststr) teststr (Underline teststr) teststr (Width teststr) teststr (Braces teststr) ) ;; Remove leading linefeeds. (while (eq "\\P" (substr teststr 1 2)) (setq teststr (substr teststr 3) str (vl-string-subst "" "\\P" str) ) ) (RE:Replace " " " \\\\P|\\\\P |\\\\P" str) ) ;; O format (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str)) ;; This option is effectively the same as the Remove Formatting > ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor. (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str)) ;; Q format - numeric value may be negative. (defun Oblique (str) ;; Any real number including negative values. (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str) ) ;; S format (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck) (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str)) (foreach x lst (setq tempstr (car x) pos (cadr x) origstr tempstr ) ;; Remove formatting from test string other than stacking. (setq teststr (Alignment str) teststr (Color teststr) teststr (Font teststr) teststr (Height teststr) teststr (Linefeed teststr) teststr (Overline teststr) teststr (Paragraph teststr) teststr (Oblique teststr) teststr (Tracking teststr) teststr (Underline teststr) teststr (Width teststr) teststr (Braces teststr) ) ;; Remove all "{" characters if present. Added JB 2/1/2010. (setq teststr (RE:Replace "" "[{]" teststr)) ;; Get the stacked position within test string. (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr))) ;; Avoid an error with substr if testpos is zero. ;; A space should not be added given a stacked ;; fraction string which is simply like this 1/2" anyway. (if (/= 0 testpos) (setq numcheck (substr teststr testpos 1)) ) ;; Check whether the character before a stacked string/fraction ;; is a number. Add a space if it is. (if (and numcheck (<= 48 (ascii numcheck) 57)) (setq tempstr (RE:Replace " " "\\\\S" tempstr)) (setq tempstr (RE:Replace "" "\\\\S" tempstr)) ) (setq tempstr (RE:Replace "/" "[#]" tempstr) tempstr (RE:Replace "" "[;]" tempstr) tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr) tempstr (RE:Replace "" "\\^" tempstr) str (vl-string-subst tempstr origstr str pos) ) ) str ) ;; T format (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str)) ;; U format (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str)) ;; W format (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str)) ;; ~ format ;; In 2008 a hard space includes font formatting. ;; In 2004 it does not, simply this \\~. (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str)) ;; Remove curly braces. Called after other formatting is removed. (defun Braces (str / lst origstr tempstr len teststr) (setq lst (RE:Execute "{[^\\\\]+}" str)) (foreach x lst (setq origstr (car x) tempstr (RE:Replace "" "[{}]" origstr) str (vl-string-subst tempstr origstr str) ) ) ;; Added JB 12/20/2009 ;; Last ditch attempt at remove braces from start and end of string. (setq len (strlen str)) (if (and (= 123 (ascii (substr str 1 1))) (= 125 (ascii (substr str len 1))) (setq teststr (substr str 2)) (setq teststr (substr teststr 1 (1- (strlen teststr)))) (not (vl-string-search "{" teststr)) (not (vl-string-search "}" teststr)) ) (setq str teststr) ) str ) ;;;;; End remove formatting sub-functions ;;;;; ;;;;; Start primary function ;;;;; ;; Temporarily replace literal backslashes with a unique string. ;; Literal backslashes are restored at end of function. By Steve Doman. (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">")) (setq text (RE:Replace slashflag "\\\\\" str)) ;; Temporarily replace literal left curly brace. (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">")) (setq text (RE:Replace lbrace "\\\\{" text)) ;; Temporarily replace literal right curly brace. (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>")) (setq text (RE:Replace rbrace "\\\\}" text)) (if (or (vl-position "A" formats) (and (vl-position "*" formats) (not (vl-position "^A" formats))) ) (setq text (Alignment text)) ) (if (or (vl-position "B" formats) (and (vl-position "*" formats) (not (vl-position "^B" formats))) ) (setq text (Tab text)) ) (if (or (vl-position "C" formats) (and (vl-position "*" formats) (not (vl-position "^C" formats))) ) (setq text (Color text)) ) (if (or (vl-position "F" formats) (and (vl-position "*" formats) (not (vl-position "^F" formats))) ) (setq text (Font text)) ) (if (or (vl-position "H" formats) (and (vl-position "*" formats) (not (vl-position "^H" formats))) ) (setq text (Height text)) ) (if (or (vl-position "L" formats) (and (vl-position "*" formats) (not (vl-position "^L" formats))) ) (setq text (Linefeed text)) ) (if (or (vl-position "O" formats) (and (vl-position "*" formats) (not (vl-position "^O" formats))) ) (setq text (Overline text)) ) (if (or (vl-position "P" formats) (and (vl-position "*" formats) (not (vl-position "^P" formats))) ) (setq text (Paragraph text)) ) (if (or (vl-position "Q" formats) (and (vl-position "*" formats) (not (vl-position "^Q" formats))) ) (setq text (Oblique text)) ) (if (or (vl-position "S" formats) (and (vl-position "*" formats) (not (vl-position "^S" formats))) ) (setq text (Stacking text)) ) (if (or (vl-position "T" formats) (and (vl-position "*" formats) (not (vl-position "^T" formats))) ) (setq text (Tracking text)) ) (if (or (vl-position "U" formats) (and (vl-position "*" formats) (not (vl-position "^U" formats))) ) (setq text (Underline text)) ) (if (or (vl-position "W" formats) (and (vl-position "*" formats) (not (vl-position "^W" formats))) ) (setq text (Width text)) ) (if (or (vl-position "~" formats) (and (vl-position "*" formats) (not (vl-position "^~" formats))) ) (setq text (HardSpace text)) ) (setq text (Braces (RE:Replace "\" slashflag text)) text (RE:Replace "\\{" lbrace text) text (RE:Replace "\\}" rbrace text) ) text ) ; end StripFormat (defun _sel (/ o) (if (setq o (AT:Entsel t (strcat "\nSelect text object to " *AV:Fnc* " or " (if final "[Add/Divide/Multiply/Subtract/Type]: " "[Type]: " ) ) '("V" (0 . "AECC_COGO_POINT,AECC_POINT,ATTDEF,ATTRIB,MULTILEADER,MTEXT,TEXT")) (if final "Add Divide Multiply Subtract Type" "Type" ) ) ) (cond ((eq o "Add") (setq f "+") (setq *AV:Fnc* "Add") (_sel)) ((eq o "Divide") (setq f "/") (setq *AV:Fnc* "Divide") (_sel)) ((eq o "Multiply") (setq f "*") (setq *AV:Fnc* "Multiply") (_sel)) ((eq o "Subtract") (setq f "-") (setq *AV:Fnc* "Subtract") (_sel)) ((eq o "Type") (initget 6) (setq o (getreal (strcat "\nNumber to " *AV:Fnc* ": ")))) (T o) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (vl-load-com) (or *AV:Fnc* (setq *AV:Fnc* "Add")) (and (setq dZin (getvar 'dimzin)) (setvar 'dimzin 0)) (initget 0 "Add Divide Multiply Subtract") (setq *AV:Fnc* (cond ((getkword (strcat "\nChoose function [Add/Divide/Multiply/Subtract] <" *AV:Fnc* ">: ") ) ) (*AV:Fnc*) ) ) (setq f (cond ((eq *AV:Fnc* "Add") "+") ((eq *AV:Fnc* "Divide") "/") ((eq *AV:Fnc* "Multiply") "*") ((eq *AV:Fnc* "Subtract") "-") ) i 0. ) (while (setq obj (_sel)) (if (cond ;; real value ((eq (type obj) 'REAL) (setq num obj)) ;; LDD point ((and (eq (vla-get-objectname obj) "AeccDbPoint") (not (vl-catch-all-error-p (setq num (vl-catch-all-apply (function (lambda () (cadddr (assoc 11 (entget (vlax-vla-object->ename obj))))) ) ) ) ) ) ) num ) ;; C3D point ((and (eq (vla-get-objectname obj) "AeccDbCogoPoint") (not (vl-catch-all-error-p (setq num (vl-catch-all-apply (function vlax-get-property) (list obj 'Elevation))) ) ) ) (setq num (car (AT:ExtractNumbers num))) ) ;; attribute, multileader, mtext, text (T ;;(T (setq num (apply (function (eval (read f))) (AT:ExtractNumbers (vla-get-textstring obj))))) ;;(T (setq num (car (AT:ExtractNumbers (vla-get-textstring obj))))) ;| (setq num ((lambda (n) (foreach x (AT:ExtractNumbers (StripFormat (vla-get-textstring obj) "*")) (setq n ((eval (read f)) x n)) ) ) 0. ) ) |; (if (> (length (setq num (AT:ExtractNumbers (CV:StripFormat (vla-get-textstring obj) "*")))) 1 ) (if (setq num (AT:ListSelect (strcat "Multiple numbers to: " *AV:Fnc*) "Choose numbers:" "10" "5" "true" (mapcar (function vl-princ-to-string) num) ) ) (setq i (+ i (1- (length num))) num ((lambda (n) (foreach x (mapcar (function atof) num) (setq n ((eval (read f)) x n)) ) ) 0. ) ) ) (setq num (car num)) ) ) ) (if final (progn (setq final ((eval (read f)) final num) nStr (strcat nStr " " f " " (vl-princ-to-string num)) i (1+ i) ) (princ (strcat nStr " = " (vl-princ-to-string final))) ) (progn (setq final num nStr (strcat "\n" (vl-princ-to-string num)) i (1+ i) ) (princ (strcat nStr " " f)) ) ) (princ "\nValue does not contain number!") ) ) (and nStr (> i 1) (if (and (eq *AV:Fnc* "Add") (not (wcmatch nStr "*/*,*`**,*-*"))) (setq pt (initget 0 "Average") pt (getpoint (strcat nStr " = " (vl-princ-to-string final) "\nSpecify text placement or [Average]: " ) ) ) (setq pt (getpoint (strcat nStr " = " (vl-princ-to-string final) "\nSpecify text placement: ")) ) ) (if (vl-consp pt) (AT:MText (trans pt 1 0) (rtos final) nil nil 5) (if (setq pt (getpoint (strcat nStr " = " (vl-princ-to-string final) " / " (vl-princ-to-string (fix i)) " = " (vl-princ-to-string (/ final i)) "\nSpecify text placement point: " ) ) ) (AT:MText (trans pt 1 0) (rtos (/ final i)) nil nil 5) ) ) ) (*error* nil) (princ) ) 276810-deneme1.dwg 276810-deneme2.dwg baha07 (05.10.2024 11:06 GMT) |