01.06.2012 09:05    

ProhibiT
Seçilen Line guruplarını (demetlerini) işleme alarak, 2 ayrı doğrultudaki Line objelerini, verilen Radius ve diğer kriterlere göre sıralı olarak Fillet eder. Polyline objelerinde işlem yapmaz.

· Fonksiyon çalıştırıldığında, Fillet edilecek Line objelerinin seçilmesini ister. Seçim tek seferde, window veya crossing ile yapılabileceği gibi, tıklayarak tekli de seçim yapılabilir. Seçim yapılırken AutoCAD genel "select objects" mantığı geçerlidir, istenildiği gibi "add", "remove" işlemi uygulanabilir.

· Line objelerinin seçilmesini isteyen "select objects:" mesajı alındığında, Enter (veya Sağ tuş) girilirse, minimum iç yarıçap (minimum radius) ve Radius tipi (sabit veya paralel) seçilebilir. Radius belirlenirken doğrudan değer girebilebileceği gibi, 2 nokta girilerek te belirlenebilir. Radius belirlenmediğinde fonksiyon kendiliğinden 0 (sıfır) değerini kullanacaktır. Minimum Radius değeri 0 olduğunda başkaca soru sorulmaksızın, bütün radius'ler 0 (sabit) alınır. Belirlenen Radius değeri ve Radius tipi drawing dosyası kapatılıncaya kadar unutulmaz, açıklanan şekilde istenen anda değiştirilebilir.

· Seçilen Line objeleri iki gurup halinde kendi içlerinde paralel olmalı, Line gurupları aynı doğrultuda veya paralel olmamalıdır.

· Line objeleri için aykırılık durumu (mesela z koordinatının farklı olması gibi) kontrol edilmemiştir. Böyle durumlarda fonksiyon hata ile sonuçlanır.

· Fonksiyon, seçilecek Line'ların Layer, Color, LineType, LineWeight,... gibi özellikleriyle ilgilenmez.

· Line demetleri herhangi bir açıyla (0, 180 ve 360 derece hariç) birleşebilir.

· Doğru guruplarında, ara mesafeler, iki gurup için farklı olabilir.

· Radius seçilmişse, Arc elemanları, o anda geçerli olan Layer, Color, LineType, LineWeight,... kullanılarak oluşturulurlar.

Kullanıma hazır Lisp dosyasını indirmek için tıklayınız. 174410-mfl.rar Click here to download ready to use Lisp File.

Kod:

;|===========================================================================|
| mFL: Multiple Fillet                                                      |
|   Seçilen obje gurubu içinde iki ayrı doğrultuda, kendi içinde biribirine |
|   paralel doğruları yerleşim sıralarına uygun olarak Fillet eder.         |
|          Author: M. Şahin Güvercin - www.autocadokulu.com - 01.06.2012    |
|                                                                           |
|                      Hata yakalama fonksiyonu güncellendi - 25.10.2021    |
|---------------------------------------------------------------------------|;
(defun c:mFL (/ AnG AnS Ds1 Ds2 DsT eP ePT iNp ipT Ln1 Ln2 LnS m myerr n o obJ
              oFr olderr oRa orT p1 p2 p3 PnT Pv1 Pv2 PvP PvT Rad RdS rTp sP
              SpT sR1 sR2 tLr ucL)
  (vl-load-com) (setq olderr *error* ocmd (getvar "cmdecho"))
  (defun *error* (ocmd / er)
    (if (and (member er '("Function cancelled" "quit/exit abort"))
             (= (logand (getvar "undoctl") 8) 8))
      (progn (command-s "_.undo" "e") (setvar "FiLLetRad" oFr)
        (setvar "cmdecho" ocmd))) (princ (strcat "\n" er))
    (setq *error* olderr) (prin1))
  (setvar "cmdecho" 0) (command "_.undo" "group")
  (setq tLr 1.0E-08  sP 'StartPoint eP 'EndPoint oFr (getvar "FiLLetRad")
        oRa (if oRa oRa 0.0) Rad oRa orT (if orT orT "Fixed") rTp orT)
  (princ "\nSelect Lines to be Fillet [Enter: Specify Radius and Type]: ")
  (while (not (setq ObJ (ssget (list (cons 0 "Line")))))
    (setq Rad (getdist (strcat "\nSpecify Minimum Fillet Radius <"
                         (rtos oRa) ">: "))) (if (not Rad) (setq Rad oRa))
    (if (zerop Rad) (setq rTp "Fixed")
      (setq RtP (initget "Fixed Parallel")
            rTp (getkword(strcat "\nRadius Type <"orT">: [Fixed/Parallel]: "))
            rTp (if rTp rTp orT)))) (setq oRa Rad orT rTp n (sslength ObJ))
  (while (>= (setq n (1- n)) 0)
    (setq AnG (vlax-get-property(vlax-ename->vla-object(ssname ObJ n))'AngLe)
          AnG (if(>= AnG pi)(- AnG pi)AnG) AnG (atof (rtos AnG 2 8))
          Ans (append (list AnG) (vl-remove AnG Ans))))
  (while (< (setq n (1+ n)) (sslength ObJ))
    (setq PvT (vlax-ename->vla-object (ssname ObJ n))
          AnG (vlax-get-property PvT'AngLe) AnG (if(>= AnG pi)(- AnG pi) AnG))
    (if (equal Ang (nth 0 Ans) tLr) (setq Ln1 (append Ln1 (list PvT)))
      (if (equal AnG (nth 1 Ans) tLr) (setq Ln2 (append Ln2 (list PvT))))))
  (if(<(Length Ln1)(length Ln2))(setq LnS(length Ln1))(setq Lns(length Ln2)))
  (setq n -1 o 0)
  (while (< (setq m -1 n (1+ n)) Lns)
    (while (< (setq m (1+ m)) Lns)
      (setq iPt (append iPt (list (vlax-safearray->list (vlax-variant-value
                (vla-intersectwith(nth n Ln1)(nth m Ln2)AcExtendBoth))))))))
  (while (<= (setq n -1 o (1+ o)) 2)
    (while (< (setq  DsT nil PnT nil ucL nil m -1 n (1+ n)) Lns)
      (setq PvT (nth n (eval (read (strcat "Ln" (itoa o)))))
       SpT(vlax-safearray->list(vlax-variant-value(vlax-get-property PvT sP)))
       EpT(vlax-safearray->list(vlax-variant-value(vlax-get-property PvT eP))))
      (while (< (setq m (1+ m)) (length iPt)) (setq iNp (nth m iPt))
        (if(equal(distance iNp(vlax-curve-getClosestPointTo PvT iNp T))0.0 tLr)
          (if (< (distance (vlax-curve-getClosestPointTo PvT iNp) SpT)
                 (distance (vlax-curve-getClosestPointTo PvT iNp) EpT))
            (if (not DsT) (setq PnT iNp ucL 'StartPoint Dst (distance PnT EpT))
   (if(<(distance iNp EpT)DsT)(setq PnT iNp ucL sP DsT(distance PnT EpT))))
           (if (not DsT) (setq PnT iNp ucL eP Dst (distance PnT SpT))
   (if(<(distance iNp SpT)DsT)(setq PnT iNp ucL eP DsT(distance PnT SpT)))))))
     (vlax-put-property PvT ucL (vlax-3d-point PnT)))) (setq n -1)
(while (< (setq m -1 n (1+ n)) LnS)
   (while (< (setq m (1+ m)) LnS)
     (if (not (minusp (vlax-safearray-get-u-bound (setq o (vlax-variant-value
               (vla-intersectwith (nth n Ln1) (nth m Ln2) AcExtendNone))) 1)))
       (setq Pv1 (nth n Ln1) Pv2 (nth m Ln2) PvP (vlax-safearray->list o)))))
(setq m 0)
  (while (<= (setq n -1 m (1+ m)) 2)
    (while (< (setq n (1+ n)) LnS)
      (set(read(strcat"Ds"(itoa m)))(append(eval(read(strcat"Ds"(itoa m))))
               (list(distance PvP(vlax-curve-getclosestPointTo
                            (nth n(eval(read(strcat"Ln"(itoa m)))))PvP T)))))))
  (setq sR1 (vl-sort-i Ds1 '<) sR2 (vl-sort-i Ds2 '<)
        Ds1 (vl-sort Ds1 '<) Ds2 (vl-sort Ds2 '<) n -1)
  (while (< (setq n (1+ n)) LnS)
    (if (zerop Rad) (setq RdS (append RdS (list 0)))
      (if (= rTp "Fixed") (setq RdS (append RdS (list Rad)))
        (if (< (nth n Ds1) (nth n Ds2))
          (setq RdS (append RdS (list (+ Rad (nth n Ds1)))))
          (setq RdS (append RdS (list (+ Rad (nth n Ds2)))))))))
  (mapcar '(lambda (p1 p2 p3) (setvar "FiLLetRad" p1)
             (vl-cmdf "FiLLet" (vlax-vla-object->ename (nth p2 Ln1))
                      (vlax-vla-object->ename (nth p3 Ln2)))) RdS sR1 sR2)
  (command "_.undo" "e") (setvar "FiLLetRad" oFr) (setvar "cmdecho" ocmd)
  (setq *error* olderr) (prin1))


Fonksiyonun çalışma mantığı ve Algoritmasını uzun uzun anlatmaya gerek görmedim.

Linkleri görebilmek için ÜYE olmalısınız.

linkinde paylaşılan eLbw fonksiyonunda açıkladığım mantık burada da geçerli.

Hata yakalama fonksiyonu güncellendi. 21.10.2021

ProhibiT (25.10.2021 08:54 GMT)

02.06.2012 09:05    

halilozcakir
Hocam mükemmel olmuş.
hörmetlee gari :) ellenizden öperin.
saygılar..

08.04.2014 18:05    

mikemoon
kare veya dikdörtgen olan çizimlere radüs atmıyor.
kare veya dikdörtgen çizimlerede radüs atacak şekilde ayarlayabilirmisiniz lispi.

09.04.2014 05:49    

halilozcakir
çoklu fillette objeler line olmalı.
dikdörtgen yada kare pline objeyi tüm köşe yada kırılma açı değiştirme noktalarından toptan fillet etmek istiyorsan

fillet komutunun alt komutu olan P yi kullan.

09.04.2014 17:51    

mikemoon
ben resimdeki gibi yaptığım çizimleri tek seferde seçip radüs atan lispe ihtiyacım var.

10.04.2014 07:00    

sahin460
Yine harika olmuş. Ellerinize sağlık. Fonksiyon pline çizimler içinde yazılabilir mi? İyi çalışmalar

04.01.2015 10:16    

edpckn
şifre istiyor nasıl açılacak

27.10.2015 15:33    

halilozcakir
Hocam merhaba , multi fillet lispi ekteki objeye neden işlemez anlamış değilim. bir mühendislik firmasının magicad ile çizildiğini tahmin ettiğim çizimden overkil ve cds ile toparlayıp temizlediğim paftadan bir parça ekliyorum yorumunuz ne olur acaba 64792--purge.dwg

27.10.2015 16:00    

mttlp
z degerlerini kontrol et magicad 3 boyut lu çizm için kullanıyorum

04.11.2015 12:13    

halilozcakir
Z ler 0 da benim anlamadığım Autocad ile magicad arasında herhalde bir anlaşmama sürtüşme var birbirinin işine sürekli laf söyleyen , beğenmeyen sahacı ile projeci gibiler.
İstanbul'da fazlaca proje işi yapan bir firma bu magicad i kullanan yoksa önemli değil her şantiyede büyüklerinde hele bu karşıma çıkıyor.

04.11.2015 12:49    

Travaci
mikemoon


Fillet -> Radius -> Polyline

04.11.2015 13:46    

mikemoon
teşekkürler

07.11.2015 12:47    

halilozcakir
Güncel .. Hocam merhaba , multi fillet lispi ekteki objeye neden işlemez anlamış değilim. bir mühendislik firmasının magicad ile çizildiğini tahmin ettiğim çizimden overkil ve cds ile toparlayıp temizlediğim paftadan bir parça ekliyorum yorumunuz ne olur acaba 64792--purge.dwg

08.11.2015 16:20    

mikemoon
güncel çoklu fillet atan lisp kodları aşağıdadır.
komut satırına fml yazın ve fillet atmak istediğiniz çizimi seçin ve radüs girin

(defun _reml ( l1 l2 / a n ls )
(while
(setq n nil
a (car l2)
)
(while (and l1 (null n))
(if (equal a (car l1) 1e-6)
(setq l1 (cdr l1)
n t
)
(setq ls (append ls (list (car l1)))
l1 (cdr l1)
)
)
)
(setq l2 (cdr l2))
)
(append ls l1)
)

(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)

(defun c:fml ( / osm ape ss frad i ent p1 p2 ptlst aptlst1 aptlst2 arcchk intptlst ss2lin ptt1 ptt2 )
(vl-load-com)
(setq ape (getvar 'aperture))
(setq osm (getvar 'osmode))
(setvar 'aperture 1)
(setvar 'osmode 0)
(command "_.zoom" "e")
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(prompt "\nSelect lines touching each other to apply fillet, or select lines and arcs previously filleted to modify existing fillet")
(while (not (setq ss (ssget "_:L" '((0 . "LINE,ARC"))))))
(setq frad (getvar 'filletrad))
(setq frad (getdist (strcat "\nPick radius for fillet <" (rtos frad) "> : ")))
(if frad (setvar 'filletrad frad))
(setq i -1)
(while (setq ent (ssname ss (setq i (1+ i))))
(if (eq (cdr (assoc 0 (entget ent))) "LINE")
(progn
(setq p1 (cdr (assoc 10 (entget ent))) p2 (cdr (assoc 11 (entget ent))))
(setq ptlst (cons p1 ptlst) ptlst (cons p2 ptlst))
)
(progn
(setq p1 (polar (cdr (assoc 10 (entget ent))) (cdr (assoc 50 (entget ent))) (cdr (assoc 40 (entget ent)))))
(setq p2 (polar (cdr (assoc 10 (entget ent))) (cdr (assoc 51 (entget ent))) (cdr (assoc 40 (entget ent)))))
(setq aptlst1 (cons p1 aptlst1) aptlst2 (cons p2 aptlst2))
(setq arcchk T)
(entdel ent)
)
)
)
(setq intptlst (_reml ptlst (acet-list-remove-duplicates ptlst 1e-6)))
(if arcchk
(mapcar '(lambda ( a b )
(command "_.zoom" "w" (car (zoom_2_object (list a b))) (cadr (zoom_2_object (list a b))))
(command "_.fillet" (osnap a "_nea") (osnap b "_nea"))
(command "_.zoom" "p")
) aptlst1 aptlst2)
(foreach pt intptlst
(setq ss2lin (ssget "_C" pt pt))
(setq ptt1 (mid (mid (cdr (assoc 10 (entget (ssname ss2lin 0)))) (cdr (assoc 11 (entget (ssname ss2lin 0))))) pt))
(setq ptt2 (mid (mid (cdr (assoc 10 (entget (ssname ss2lin 1)))) (cdr (assoc 11 (entget (ssname ss2lin 1))))) pt))
(command "_.fillet" (list (ssname ss2lin 0) ptt1) (list (ssname ss2lin 1) ptt2))
)
)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar 'aperture ape)
(setvar 'osmode osm)
(princ)
)

10.11.2015 08:59    

halilozcakir
yok gene aynı :( radius verdiğim halde içtekini 0 radiüsle birleştirip dıştakini de onun hizasına ex ediyor ve çıkıyor bence sorun 2015 ile Windows arasında.

18.11.2015 15:16    

halilozcakir
2015 ile olmayan 2013 ile kısmen de olsa oluyor bence Hocamızın lispine değerli yazılımına sabotaj veya engelleme yaptılar. yada windosws tan kaynaklı nedenini bulamadım

23.11.2015 07:40    

halilozcakir
Hata kodu şu; VVC: Internal Error

23.05.2019 10:16    

kral87
Merhabalar,
toplu olarak line için fillet yapılan bu komutun polyline içinde bir autolispi yazılabilirmi yada varmıdır?
teşekkürler.

23.05.2019 11:20    

Travaci
kral87


Daha önce paylaşıldı, biraz bakarsanız bulabilirsiniz

24.05.2019 09:04    

kral87
Merhaba travaci bey
demek istediğim polyline ile çizilmiş çizginin köşelerine radüs vermek değil MFL komutundaki gibi yatay ve dikey çizilmiş pline çizgileri toplu fillet yapmak MFL komutu polyline çizgilerde çalışmıyor.
teşekkürler

> 1 <
Copyright © 2004-2022 SQL: 2.913 saniye - Sorgu: 108 - Ortalama: 0.02697 saniye