wizman Posted March 22, 2010 Posted March 22, 2010 i gave a shot at this, i'll try to post my code if i find time to clean it tomorrow. Quote
hkncdrc Posted September 10, 2015 Posted September 10, 2015 i gave a shot at this, i'll try to post my code if i find time to clean it tomorrow. Hello Everyone, Do you think that it is possible to create a lisp to execute an operation descripted below. I think that it would be very useful and time-saving application. Would you help or consult me ? Maybe _LISP start single or double ? radius (available) first point (object or gap to the click) second point (available on line over the click) _LISP finish Quote
marko_ribar Posted September 10, 2015 Posted September 10, 2015 Single and double mode (read carefully what is asked when lisp is running) : (defun c:filletlines ( / *error* v^v unit acos angle3d marc *adoc* osm ssol ptol ol pt ssml ml olsp olep mlsp mlep ip frad vol vml1 vml2 cp1 d1 cp2 d2 aep1 aep2 aep11 aep12 aep21 aep22 ) (vl-load-com) (defun *error* ( msg ) (if osm (setvar 'osmode osm)) (vla-endundomark *adoc*) (if msg (prompt msg)) (princ) ) (defun v^v ( u v ) (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1)) ) (defun unit ( v ) (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) ) (defun acos ( x ) (cond ((equal x 1.0 1e- 0.0) ((equal x -1.0 1e- pi) ((equal x 0.0 1e- (/ pi 2.0)) ((equal x -0.0 1e- (* 3.0 (/ pi 2.0))) ((atan (/ (sqrt (- 1.0 (* x x))) x))) ) ) (defun angle3d ( p1 por p2 / vec1 vec2 dd ang ) (setq vec1 (unit (mapcar '- p1 por)) vec2 (unit (mapcar '- p2 por)) dd (distance vec1 vec2) ang (acos (- 1.0 (/ (expt dd 2) 2.0))) ) (if (minusp ang) (+ ang pi) ang) ) (defun marc ( c p1 p2 / dxf10 dxf40 dxf210 dxf50 dxf51 uz ) (setq dxf10 (trans c 0 (setq uz (v^v (mapcar '- p1 c) (mapcar '- p2 c))))) (setq dxf40 (distance c p1)) (setq dxf210 (unit uz)) (setq dxf50 (angle dxf10 (trans p1 0 uz))) (setq dxf51 (angle dxf10 (trans p2 0 uz))) (entmakex (list '(0 . "ARC") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 dxf10) (cons 40 dxf40) (cons 210 dxf210) '(100 . "AcDbArc") (cons 50 dxf50) (cons 51 dxf51))) ) (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark *adoc*) (setq osm (getvar 'osmode)) (setvar 'osmode 2592) (prompt "\nPick object line to fillet from...") (setq ssol (ssget "_+.:E:S:L" '((0 . "LINE")))) (if ssol (setq ptol (vlax-curve-getclosestpointto (setq ol (ssname ssol 0)) (trans (cadr (grread t)) 1 0)))) (while (not ssol) (prompt "\nMissed... Please pick object line on ulocked layer to fillet from again...") (setq ssol (ssget "_+.:E:S:L" '((0 . "LINE")))) (if ssol (setq ptol (vlax-curve-getclosestpointto (setq ol (ssname ssol 0)) (trans (cadr (grread t)) 1 0)))) ) (setq pt (getpoint "\nPick point on main line to fillet to (intersection, apparent intersection - double fillet with trim; on main line choose side to fillet to - single fillet...)")) (setq ssml (ssget "_C" pt pt '((0 . "LINE")))) (if (ssmemb ol ssml) (ssdel ol ssml) ) (while (or (/= (sslength ssml) 1) (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 (entget (ssname ssml 0)))))))))) (prompt "\nInvalid point specification... Please pick point on main line on ulocked layer to fillet to again...") (setq pt (getpoint "\nPick point on main line to fillet to (intersection, apparent intersection - double fillet with trim; on main line choose side to fillet to - single fillet...)")) (setq ssml (ssget "_C" pt pt '((0 . "LINE")))) (if (ssmemb ol ssml) (ssdel ol ssml) ) ) (setvar 'osmode 0) (setq ml (ssname ssml 0)) (setq olsp (vlax-curve-getstartpoint ol) olep (vlax-curve-getendpoint ol) mlsp (vlax-curve-getstartpoint ml) mlep (vlax-curve-getendpoint ml)) (setq ip (inters olsp olep mlsp mlep nil)) (initget 4) (setq frad (getdist "\nPick or specify fillet radius <0.0> : ")) (if (null frad) (setq frad 0.0)) (if (equal (trans pt 1 0) ip 1e-6) (if (equal (distance olsp ip) (+ (distance olsp ptol) (distance ptol ip)) 1e-6) (if (equal frad 0.0 1e-6) (entupd (cdr (assoc -1 (entmod (subst (cons 11 ip) (assoc 11 (entget ol)) (entget ol)))))) (progn (setq vol (unit (mapcar '- olsp olep))) (setq vml1 (unit (mapcar '- mlsp mlep))) (setq vml2 (mapcar '- vml1)) (setq cp1 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml1)) (list 2.0 2.0 2.0))) (setq d1 (/ frad (sin (angle3d cp1 ip (mapcar '+ ip vml1))))) (setq cp1 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp1 ip)) (list d1 d1 d1)))) (setq aep1 (vlax-curve-getclosestpointto ol cp1 t) aep2 (vlax-curve-getclosestpointto ml cp1 t)) (marc cp1 aep1 aep2) (setq aep11 aep1) (setq aep21 aep2) (setq cp2 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml2)) (list 2.0 2.0 2.0))) (setq d2 (/ frad (sin (angle3d cp2 ip (mapcar '+ ip vml2))))) (setq cp2 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp2 ip)) (list d2 d2 d2)))) (setq aep1 (vlax-curve-getclosestpointto ol cp2 t) aep2 (vlax-curve-getclosestpointto ml cp2 t)) (marc cp2 aep2 aep1) (setq aep12 aep1) (setq aep22 aep2) (if (< (distance olsp aep11) (distance olsp aep12)) (entupd (cdr (assoc -1 (entmod (subst (cons 11 aep12) (assoc 11 (entget ol)) (entget ol)))))) (entupd (cdr (assoc -1 (entmod (subst (cons 11 aep11) (assoc 11 (entget ol)) (entget ol)))))) ) (command "_.TRIM" "" "_non" (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0)) "_non" ip) (while (< 0 (getvar 'cmdactive)) (command "")) ) ) (if (equal frad 0.0 1e-6) (entupd (cdr (assoc -1 (entmod (subst (cons 10 ip) (assoc 10 (entget ol)) (entget ol)))))) (progn (setq vol (unit (mapcar '- olep olsp))) (setq vml1 (unit (mapcar '- mlsp mlep))) (setq vml2 (mapcar '- vml1)) (setq cp1 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml1)) (list 2.0 2.0 2.0))) (setq d1 (/ frad (sin (angle3d cp1 ip (mapcar '+ ip vml1))))) (setq cp1 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp1 ip)) (list d1 d1 d1)))) (setq aep1 (vlax-curve-getclosestpointto ol cp1 t) aep2 (vlax-curve-getclosestpointto ml cp1 t)) (marc cp1 aep2 aep1) (setq aep11 aep1) (setq aep21 aep2) (setq cp2 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml2)) (list 2.0 2.0 2.0))) (setq d2 (/ frad (sin (angle3d cp2 ip (mapcar '+ ip vml2))))) (setq cp2 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp2 ip)) (list d2 d2 d2)))) (setq aep1 (vlax-curve-getclosestpointto ol cp2 t) aep2 (vlax-curve-getclosestpointto ml cp2 t)) (marc cp2 aep1 aep2) (setq aep12 aep1) (setq aep22 aep2) (if (< (distance olep aep11) (distance olep aep12)) (entupd (cdr (assoc -1 (entmod (subst (cons 10 aep12) (assoc 10 (entget ol)) (entget ol)))))) (entupd (cdr (assoc -1 (entmod (subst (cons 10 aep11) (assoc 10 (entget ol)) (entget ol)))))) ) (command "_.TRIM" "" "_non" (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0)) "_non" ip) (while (< 0 (getvar 'cmdactive)) (command "")) ) ) ) (if (equal (distance olsp ip) (+ (distance olsp ptol) (distance ptol ip)) 1e-6) (if (equal frad 0.0 1e-6) (entupd (cdr (assoc -1 (entmod (subst (cons 11 ip) (assoc 11 (entget ol)) (entget ol)))))) (progn (setq vol (unit (mapcar '- olsp olep))) (if (equal (distance mlsp ip) (+ (distance mlsp pt) (distance pt ip)) 1e-6) (setq vml1 (unit (mapcar '- mlsp mlep))) (setq vml1 (unit (mapcar '- mlep mlsp))) ) (setq cp1 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml1)) (list 2.0 2.0 2.0))) (setq d1 (/ frad (sin (angle3d cp1 ip (mapcar '+ ip vml1))))) (setq cp1 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp1 ip)) (list d1 d1 d1)))) (setq aep1 (vlax-curve-getclosestpointto ol cp1 t) aep2 (vlax-curve-getclosestpointto ml cp1 t)) (marc cp1 aep1 aep2) (entupd (cdr (assoc -1 (entmod (subst (cons 11 aep1) (assoc 11 (entget ol)) (entget ol)))))) ) ) (if (equal frad 0.0 1e-6) (entupd (cdr (assoc -1 (entmod (subst (cons 10 ip) (assoc 10 (entget ol)) (entget ol)))))) (progn (setq vol (unit (mapcar '- olep olsp))) (if (equal (distance mlsp ip) (+ (distance mlsp pt) (distance pt ip)) 1e-6) (setq vml1 (unit (mapcar '- mlsp mlep))) (setq vml1 (unit (mapcar '- mlep mlsp))) ) (setq cp1 (mapcar '/ (mapcar '+ (mapcar '+ ip vol) (mapcar '+ ip vml1)) (list 2.0 2.0 2.0))) (setq d1 (/ frad (sin (angle3d cp1 ip (mapcar '+ ip vml1))))) (setq cp1 (mapcar '+ ip (mapcar '* (unit (mapcar '- cp1 ip)) (list d1 d1 d1)))) (setq aep1 (vlax-curve-getclosestpointto ol cp1 t) aep2 (vlax-curve-getclosestpointto ml cp1 t)) (marc cp1 aep2 aep1) (entupd (cdr (assoc -1 (entmod (subst (cons 10 aep1) (assoc 10 (entget ol)) (entget ol)))))) ) ) ) ) (*error* nil) ) Quote
marko_ribar Posted September 10, 2015 Posted September 10, 2015 Quad mode : (defun c:filletlines ( / *adoc* v^v unit acos angle3d marc ss i li lil lixl lill p pl ml mll lilr sp ep p1 p2 rlpl r a ip d v aep1 aep2 aep11 aep12 aep21 aep22 maep11 maep12 maep21 maep22 maep2s li cp dd arc ) (vl-load-com) (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))) (defun v^v ( u v ) (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1)) ) (defun unit ( v ) (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) ) (defun acos ( x ) (cond ((equal x 1.0 1e- 0.0) ((equal x -1.0 1e- pi) ((equal x 0.0 1e- (/ pi 2.0)) ((equal x -0.0 1e- (* 3.0 (/ pi 2.0))) ((atan (/ (sqrt (- 1.0 (* x x))) x))) ) ) (defun angle3d ( p1 por p2 / vec1 vec2 dd ang ) (setq vec1 (unit (mapcar '- p1 por)) vec2 (unit (mapcar '- p2 por)) dd (distance vec1 vec2) ang (acos (- 1.0 (/ (expt dd 2) 2.0))) ) (if (minusp ang) (+ ang pi) ang) ) (defun marc ( c p1 p2 / dxf10 dxf40 dxf210 dxf50 dxf51 uz ) (setq dxf10 (trans c 0 (setq uz (v^v (mapcar '- p1 c) (mapcar '- p2 c))))) (setq dxf40 (distance c p1)) (setq dxf210 (unit uz)) (setq dxf50 (angle dxf10 (trans p1 0 uz))) (setq dxf51 (angle dxf10 (trans p2 0 uz))) (entmakex (list '(0 . "ARC") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 dxf10) (cons 40 dxf40) (cons 210 dxf210) '(100 . "AcDbArc") (cons 50 dxf50) (cons 51 dxf51))) ) (vla-startundomark *adoc*) (prompt "\nSelect intersecting lines...") (setq ss (ssget "_:L" '((0 . "LINE")))) (while (not ss) (prompt "\nEmpty sel.set... Please select intersecting lines again...") (setq ss (ssget "_:L" '((0 . "LINE")))) ) (repeat (setq i (sslength ss)) (setq li (ssname ss (setq i (1- i)))) (setq lil (cons li lil)) (setq lixl (cons (entget li) lixl)) ) (setq lill lil) (foreach li1 lil (setq lill (vl-remove li1 lill)) (foreach li2 lill (if (setq p (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object li2) acextendnone)) (setq pl (cons p pl)) ) ) ) (if (null pl) (progn (prompt "\nLines don't intersect... Restart routine and choose lines that intersect each other... Quitting...") (exit) ) (vl-some '(lambda ( x ) (if (vl-every '(lambda ( p ) (vlax-curve-getparamatpoint x p)) pl) (setq ml x))) lil) ) (setq lilr (vl-remove ml lil)) (setq mll (entget ml)) (setq sp (trans (cdr (assoc 10 mll)) 0 1) ep (trans (cdr (assoc 11 mll)) 0 1)) (foreach li lilr (setq p1 (trans (cdr (assoc 10 (entget li))) 0 1) p2 (trans (cdr (assoc 11 (entget li))) 0 1)) (setq rlpl (cons (list li (vl-some '(lambda ( p ) (if (vlax-curve-getparamatpoint li p) p nil)) pl) (list p1 p2)) rlpl)) ) (initget 7) (setq r (getdist "\nPick or specify fillet radius : ")) (foreach rlp rlpl (if (eq (cadr rlp) nil) (setq rlpl (vl-remove rlp rlpl))) ) (setq rlpl (vl-sort rlpl '(lambda ( a b ) (< (distance (cadr a) (cdr (assoc 10 (entget ml)))) (distance (cadr b) (cdr (assoc 10 (entget ml)))))))) (foreach rlp rlpl (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep11 aep1) (setq aep21 aep2) (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep12 aep1) (setq aep22 aep2) (setq maep11 (mapcar '/ (mapcar '+ aep11 aep12) (list 2.0 2.0 2.0))) (setq maep21 (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0))) (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep11 aep1) (setq aep21 aep2) (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep12 aep1) (setq aep22 aep2) (setq maep12 (mapcar '/ (mapcar '+ aep11 aep12) (list 2.0 2.0 2.0))) (setq maep22 (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0))) (setq maep2s (cons (mapcar '/ (mapcar '+ maep21 maep22) (list 2.0 2.0 2.0)) maep2s)) (command "_.TRIM" "" "_non" (mapcar '/ (mapcar '+ maep11 maep12) (list 2.0 2.0 2.0)) "_end" (mapcar '/ (mapcar '+ maep11 maep12) (list 2.0 2.0 2.0))) (while (< 0 (getvar 'cmdactive)) (command "")) ) (foreach maep2 maep2s (command "_.TRIM" "" "_non" maep2 "_end" maep2) (while (< 0 (getvar 'cmdactive)) (command "")) ) (vla-endundomark *adoc*) (princ) ) Quote
hkncdrc Posted September 11, 2015 Posted September 11, 2015 Quad mode : (defun c:filletlines ( / *adoc* v^v unit acos angle3d marc ss i li lil lixl lill p pl ml mll lilr sp ep p1 p2 rlpl r a ip d v aep1 aep2 aep11 aep12 aep21 aep22 maep11 maep12 maep21 maep22 maep2s li cp dd arc ) (vl-load-com) (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))) (defun v^v ( u v ) (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1)) ) (defun unit ( v ) (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) ) (defun acos ( x ) (cond ((equal x 1.0 1e- 0.0) ((equal x -1.0 1e- pi) ((equal x 0.0 1e- (/ pi 2.0)) ((equal x -0.0 1e- (* 3.0 (/ pi 2.0))) ((atan (/ (sqrt (- 1.0 (* x x))) x))) ) ) (defun angle3d ( p1 por p2 / vec1 vec2 dd ang ) (setq vec1 (unit (mapcar '- p1 por)) vec2 (unit (mapcar '- p2 por)) dd (distance vec1 vec2) ang (acos (- 1.0 (/ (expt dd 2) 2.0))) ) (if (minusp ang) (+ ang pi) ang) ) (defun marc ( c p1 p2 / dxf10 dxf40 dxf210 dxf50 dxf51 uz ) (setq dxf10 (trans c 0 (setq uz (v^v (mapcar '- p1 c) (mapcar '- p2 c))))) (setq dxf40 (distance c p1)) (setq dxf210 (unit uz)) (setq dxf50 (angle dxf10 (trans p1 0 uz))) (setq dxf51 (angle dxf10 (trans p2 0 uz))) (entmakex (list '(0 . "ARC") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 dxf10) (cons 40 dxf40) (cons 210 dxf210) '(100 . "AcDbArc") (cons 50 dxf50) (cons 51 dxf51))) ) (vla-startundomark *adoc*) (prompt "\nSelect intersecting lines...") (setq ss (ssget "_:L" '((0 . "LINE")))) (while (not ss) (prompt "\nEmpty sel.set... Please select intersecting lines again...") (setq ss (ssget "_:L" '((0 . "LINE")))) ) (repeat (setq i (sslength ss)) (setq li (ssname ss (setq i (1- i)))) (setq lil (cons li lil)) (setq lixl (cons (entget li) lixl)) ) (setq lill lil) (foreach li1 lil (setq lill (vl-remove li1 lill)) (foreach li2 lill (if (setq p (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object li2) acextendnone)) (setq pl (cons p pl)) ) ) ) (if (null pl) (progn (prompt "\nLines don't intersect... Restart routine and choose lines that intersect each other... Quitting...") (exit) ) (vl-some '(lambda ( x ) (if (vl-every '(lambda ( p ) (vlax-curve-getparamatpoint x p)) pl) (setq ml x))) lil) ) (setq lilr (vl-remove ml lil)) (setq mll (entget ml)) (setq sp (trans (cdr (assoc 10 mll)) 0 1) ep (trans (cdr (assoc 11 mll)) 0 1)) (foreach li lilr (setq p1 (trans (cdr (assoc 10 (entget li))) 0 1) p2 (trans (cdr (assoc 11 (entget li))) 0 1)) (setq rlpl (cons (list li (vl-some '(lambda ( p ) (if (vlax-curve-getparamatpoint li p) p nil)) pl) (list p1 p2)) rlpl)) ) (initget 7) (setq r (getdist "\nPick or specify fillet radius : ")) (foreach rlp rlpl (if (eq (cadr rlp) nil) (setq rlpl (vl-remove rlp rlpl))) ) (setq rlpl (vl-sort rlpl '(lambda ( a b ) (< (distance (cadr a) (cdr (assoc 10 (entget ml)))) (distance (cadr b) (cdr (assoc 10 (entget ml)))))))) (foreach rlp rlpl (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep11 aep1) (setq aep21 aep2) (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 11 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget (car rlp)))) (cdr (assoc 10 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep12 aep1) (setq aep22 aep2) (setq maep11 (mapcar '/ (mapcar '+ aep11 aep12) (list 2.0 2.0 2.0))) (setq maep21 (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0))) (setq a (angle3d (cdr (assoc 10 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget ml))) (cdr (assoc 11 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep11 aep1) (setq aep21 aep2) (setq a (angle3d (cdr (assoc 11 (entget ml))) (cadr rlp) (cdr (assoc 10 (entget (car rlp)))))) (setq d (/ r (/ (sin (/ a 2.0)) (cos (/ a 2.0))))) (setq v (unit (mapcar '- (cdr (assoc 10 (entget (car rlp)))) (cdr (assoc 11 (entget (car rlp))))))) (setq aep1 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq v (unit (mapcar '- (cdr (assoc 11 (entget ml))) (cdr (assoc 10 (entget ml)))))) (setq aep2 (mapcar '+ (cadr rlp) (list (* (car v) d) (* (cadr v) d) (* (caddr v) d)))) (setq li (entmakex (list '(0 . "LINE") (cons 10 (cadr rlp)) (cons 11 (mapcar '/ (mapcar '+ aep1 aep2) (list 2.0 2.0 2.0)))))) (setq cp (vlax-curve-getclosestpointto li aep1 t)) (setq v (unit (mapcar '- (cadr rlp) cp))) (setq cp (mapcar '+ (cadr rlp) (list (* (- (car v)) (setq dd (sqrt (+ (expt d 2) (expt r 2))))) (* (- (cadr v)) dd) (* (- (caddr v)) dd)))) (setq arc (marc cp aep1 aep2)) (entdel li) (setq aep12 aep1) (setq aep22 aep2) (setq maep12 (mapcar '/ (mapcar '+ aep11 aep12) (list 2.0 2.0 2.0))) (setq maep22 (mapcar '/ (mapcar '+ aep21 aep22) (list 2.0 2.0 2.0))) (setq maep2s (cons (mapcar '/ (mapcar '+ maep21 maep22) (list 2.0 2.0 2.0)) maep2s)) (command "_.TRIM" "" "_non" (mapcar '/ (mapcar '+ maep11 maep12) (list 2.0 2.0 2.0)) "_end" (mapcar '/ (mapcar '+ maep11 maep12) (list 2.0 2.0 2.0))) (while (< 0 (getvar 'cmdactive)) (command "")) ) (foreach maep2 maep2s (command "_.TRIM" "" "_non" maep2 "_end" maep2) (while (< 0 (getvar 'cmdactive)) (command "")) ) (vla-endundomark *adoc*) (princ) ) :shock: marko Thank you very much :D:D Quote
marko_ribar Posted September 11, 2015 Posted September 11, 2015 :shock:marko Thank you very much :D:D You're welcome, hkncdrc, just to add reference and reverse link : http://www.cadtutor.net/forum/showthread.php?93748-Dline-Break-Fillet-............................-Break-Fillet&p=#5 M.R. Quote
hkncdrc Posted September 11, 2015 Posted September 11, 2015 Hello, again I've learned that another mate has already created something likte that. I would like to share it. Maybe anyone can go further? Note: it functions for only "double" mode. ObjCon2.lsp Quote
hkncdrc Posted September 22, 2015 Posted September 22, 2015 Hello, again I've learned that another mate has already created something likte that. I would like to share it. Maybe anyone can go further? (defun c:L9 ( / *error* adoc nVAR oVAR pto en ptl vrt pt0 pt1 em) (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end")) (princ (strcat "\nError: " errmsg))) (mapcar 'setvar nVAR oVAR) (vla-endundomark adoc) (princ)) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (setq oVAR (mapcar 'getvar (setq nVAR '("TRIMMODE" "FILLETRAD" "OSMODE" "ORTHOMODE" "SNAPMODE" "BLIPMODE" "CMDECHO")))) (if (and (not (initget 0)) (setq pto (getpoint "\nPick a point on the OBJECT: ")) (not (initget 0)) (mapcar 'setvar nVAR '(0 120 128 0 0 0 1)) (setq ptl (getpoint pto "\nPick a point on the LINE: ")) (setq en (nentselp ptl)) (setq en (car en)) (wcmatch (cdr (assoc 0 (entget en))) "LINE,LWPOLYLINE") (setq vrt (fix (vlax-curve-getParamAtPoint en ptl)) pt0 (vlax-curve-getPointAtParam en vrt) pt1 (vlax-curve-getPointAtParam en (1+ vrt))) ) (progn (setvar 'OSMODE 0) (setq em (entmakex (list (cons 0 "LINE") (cons 10 pto) (cons 11 ptl)))) (command "_.FILLET" "_U" (cons em (list pto)) (cons en (list pt0)) (cons em (list pto)) (cons en (list pt1)) "" "_.TRIM" "" "_C" (polar ptl (* 1.25 pi) 0.01) (polar ptl (* 0.25 pi) 0.01) ""))) (*error* "end") (princ) ) (defun c:L0 ( / *error* adoc nVAR oVAR pto en ptl vrt pt0 pt1 em) (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end")) (princ (strcat "\nError: " errmsg))) (mapcar 'setvar nVAR oVAR) (vla-endundomark adoc) (princ)) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (setq oVAR1 (mapcar 'getvar (setq nVAR '("TRIMMODE" "OSMODE" "ORTHOMODE" "SNAPMODE" "BLIPMODE" "CMDECHO")))) (setq oVAR (getvar "FILLETRAD")) (setq fillet (getdist (strcat "\nSpecify fillet radius : "))) (if (= fillet nil) (setq fillet oVAR)) (setvar "FILLETRAD" fillet) ;(initget "Tek Cift") ;(setq secme (getkword"\nTek Cizgi / Cift Cizgi ..[ (T)ek / ©ift] :")) ;(if (= secme nil) (setq secme "Tek")) (if (and (not (initget 0)) (setq pto (getpoint "\nPick a point on the OBJECT: ")) (not (initget 0)) (mapcar 'setvar nVAR '(0 128 0 0 0 1)) (setq ptl (getpoint pto "\nPick a point on the LINE: ")) (setq en (nentselp ptl)) (setq en (car en)) (wcmatch (cdr (assoc 0 (entget en))) "LINE,LWPOLYLINE") (setq vrt (fix (vlax-curve-getParamAtPoint en ptl)) pt0 (vlax-curve-getPointAtParam en vrt) pt1 (vlax-curve-getPointAtParam en (1+ vrt))) ) (progn (setvar 'OSMODE 0) (setq em (entmakex (list (cons 0 "LINE") (cons 10 pto) (cons 11 ptl)))) (command "_.FILLET" "_U" (cons em (list pto)) (cons en (list pt1)) "" "_.TRIM" "" "_C" (polar ptl (* 0.25 pi) 0.01) ""))) (*error* "end") (setvar "FILLETRAD" oVAR) (princ) ) (defun c:L8 ( / *error* adoc nVAR oVAR pto en ptl vrt pt0 pt1 em) (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end")) (princ (strcat "\nError: " errmsg))) (mapcar 'setvar nVAR oVAR) (vla-endundomark adoc) (princ)) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (setq oVAR1 (mapcar 'getvar (setq nVAR '("TRIMMODE" "OSMODE" "ORTHOMODE" "SNAPMODE" "BLIPMODE" "CMDECHO")))) (setq oVAR (getvar "FILLETRAD")) (setq fillet (getdist (strcat "\nSpecify fillet radius : "))) (if (= fillet nil) (setq fillet oVAR)) (setvar "FILLETRAD" fillet) ;(initget "Tek Cift") ;(setq secme (getkword"\nTek Cizgi / Cift Cizgi ..[ (T)ek / ©ift] :")) ;(if (= secme nil) (setq secme "Tek")) (if (and (not (initget 0)) (setq pto (getpoint "\nPick a point on the OBJECT: ")) (not (initget 0)) (mapcar 'setvar nVAR '(0 128 0 0 0 1)) (setq ptl (getpoint pto "\nPick a point on the LINE: ")) (setq en (nentselp ptl)) (setq en (car en)) (wcmatch (cdr (assoc 0 (entget en))) "LINE,LWPOLYLINE") (setq vrt (fix (vlax-curve-getParamAtPoint en ptl)) pt0 (vlax-curve-getPointAtParam en vrt) pt1 (vlax-curve-getPointAtParam en (1+ vrt))) ) (progn (setvar 'OSMODE 0) (setq em (entmakex (list (cons 0 "LINE") (cons 10 pto) (cons 11 ptl)))) (command "_.FILLET" "_U" (cons em (list pto)) (cons en (list pt0)) "" "_.TRIM" "" "_C" (polar ptl (* 1.25 pi) 0.01) ""))) (*error* "end") (setvar "FILLETRAD" oVAR) (princ) ) Quote
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.