;; ;;; ;;; EXFILLET.LSP -- Written by Paul Vine ;;; Copyright © 1999 by Autodesk, Inc. ;;; ;;; Your use of this software is governed by the terms and conditions of the ;;; License Agreement you accepted prior to installation of this software. ;;; Please note that pursuant to the License Agreement for this software, ;;; "[c]opying of this computer program or its documentation except as ;;; permitted by this License is copyright infringement under the laws of ;;; your country. If you copy this computer program without permission of ;;; Autodesk, you are violating the law." ;;; ;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS. ;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF ;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC. ;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE ;;; UNINTERRUPTED OR ERROR FREE. ;;; ;;; Use, duplication, or disclosure by the U.S. Government is subject to ;;; restrictions set forth in FAR 52.227-19 (Commercial Computer ;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii) ;;; (Rights in Technical Data and Computer Software), as applicable. ;;; ;;; ---------------------------------------------------------------- ;;; 31 strings. ;;; ---------------------------------------------------------------- ;;; Last Revision ;;; Credits: Inspired by the thread "Filleting two polyline segments" on ;;; news://adesknews.autodesk.com/autodesk.autocad.customization ;;; Thanks to whomever raised the issue and participants on the thread ;;; including particularly: ;;; David Garrigues and Ian White ;;; Created by Paul Vine 7/10/98 ;;; Bug fixing ... 8/6/98 ;;; Last bug fix: 9/5/98 ;;; TAHOE work (4/1/99): ;;; Changed concatenated string usage to acet-str-format ;;; Changes error handler calls to acet-error-init instead of bns* ;;; ;;; FIXES THE FOLLOWING PLINE/FILLET BUGS and WISHLIST items: ;;; 1. Filleting between anything BUT a line with a pline. ;;; This allows the user to FILLET arcs, circles, splines, ellipses, etc., with plines ;;; however, only lines get added to the pline -- STILL in 2000 ;;; 2. Filleting individual segments in a LWPOLYLINE more than once (this is fixed in 2000) ;;; 3. Filleting between two different plines. (still a problem in 2000) ;;; 4. Auto-repeats command until user hits enter. ;;; 5. Eliminates looping in "Select second object:" prompt. ;;; 6. POLYLINE option using a selection set. ;;; 7. Adds a joinmode setting to automatically join objects when feasible. ;;; TO DO: ;;; 19. Honor standard selection set acquisition like C, CP, WP, etc. ;;; 20. Allow correct undo handling of trimmode? ;;;THIS VERSION HAS THE REVISED UNDO HANDLER. (defun c:exfillet ( / option sTrim sRad iUndo sJoin);made this guy a global (acet-error-init (list (list "cmdecho" 0 "highlight" 1 "qaflags" 0 "limcheck" 0 "plinetype" 2 "clayer" (getvar "clayer") "cecolor" (getvar "cecolor") "celtype" (getvar "celtype") "pickstyle" 0 ) 0 ;flag. True means use undo for error clean up. '(myerror) );list );acet-error-init (sssetfirst nil nil) (defun myerror () (if (= (type option) 'LIST) (redraw (car option) 4) ) ) ;defun myerror (setvar "errno" 7) (setq iUndo 0) ;setq (while (= (getvar "errno") 7) (setvar "errno" 0) ;;;new code follows for status line... (cond ( (= (acet-exfillet-gettrim) 0)(setq sTrim "NOTRIM")) ( (= (acet-exfillet-gettrim) 1)(setq sTrim "TRIM")) ( (= (acet-exfillet-gettrim) 2)(setq sTrim "JOIN")) );cond ;(alert (strcat "iUndo = " (itoa iUndo))) (setq sRad (rtos (getvar "filletrad"))) ;setq (princ (acet-str-format "\nCurrent settings: Mode = %1, Radius = %2" sTrim sRad)) ;(princ (strcat "\nCurrent settings: Mode = " sTrim ", Radius = " sRad )) (initget "Polyline Radius Trim Undo") (setq option (entsel "\nSelect first object or [Polyline/Radius/Trim/Undo]: ")); (cond ((= (type option) 'LIST) (acet-exfillet-optUserPick option)) ((= option "Polyline") (acet-exfillet-optPline)) ((= option "Radius") (acet-exfillet-optRadius)) ((= option "Trim") (acet-exfillet-optTrim)) ((= option "Undo") (acet-exfillet-optUndo)) );cond );while (acet-error-restore) ) ;defun c:exfillet (defun acet-exfillet-optUndo () ; (alert (itoa iUndo)) (if (> iUndo 0) (progn ;(command "_.undo" "1") (command "_.undo" "_B") (setq iUndo (1- iUndo)) ;setq );progn (princ "\nNothing to Undo.");else if the user never started, tell 'em we're at the beginning. );if (setvar "errno" 7) );end INTERNAL UNDO (defun acet-exfillet-optPline ( / ss i ent) (setq ss (ssget '( (-4 . "") (-4 . "AND>") (-4 . "OR>") ))) ;setq (if ss (progn ;(command "_.undo" "_be") (command "_.undo" "_m") (setq i 0) ;setq (repeat (sslength ss) (setq ent (ssname ss i)) ;setq (command "_.fillet" "_P" ent) ;;this failed on 3dpolies (setq i (1+ i)) ;setq ) ;repeat ;(command "_.undo" "_end") (setq iUndo (1+ iUndo)) ;setq );progn );if (setvar "errno" 7) ) ;defun optPline (defun acet-exfillet-optRadius ( / ans) (initget 4) ; 1 line fix for negative radius. (setq ans (getdist (acet-str-format "\nEnter fillet radius <%1>: " (getvar "filletrad") ))) ;setq ;(setq ans (getdist (strcat "\nEnter fillet radius <" (rtos (getvar "filletrad"))">: " ))) ;setq (if ans (progn (command "_.undo" "_M") (setvar "filletrad" ans) (setq iUndo (1+ iUndo)) ;setq );progn ) ;if (setvar "errno" 7) );defun (defun acet-exfillet-optUserpick ( option / lsValid lsBugfix ent entType e2 ent2 bCoplanar ent2Type ss2 entlist ent2list bLayerUnLocked pickpt1 pickpt2 Color Linetype ) (if (not iUndo) (setq iUndo 0) ;setq ) ;if (setq lsValid (list "POLYLINE" "LWPOLYLINE" "LINE" "ARC" "ELLIPSE" "CIRCLE" "SPLINE" "RAY" "XLINE")) ;setq (setq lsBugfix (list "ARC" "ELLIPSE" "CIRCLE" "SPLINE" "RAY" "XLINE" "LINE")) ;setq ARC IS THE ONLYTHING THAT (setq ent (car option)) ;setq ^^^^^^^ is a bug fix for filleting fit- and spline-curved plines to lines (setq pickpt1 (osnap (cadr option ) "_nea")) ;setq (redraw ent 3) (setq entlist (entget ent)) ;setq (setq entType (cdr (assoc 0 entlist)) ;setq bLayerUnLocked (acet-layer-locked (cdr (assoc 8 entlist))) ;setq bCoplanar (acet-exfillet-bCoplanar ent)); (if (and (member entType lsValid) (not bLayerUnLocked) bCoplanar ) ;if the first one is good, look at the second one. (progn (setq ent2type nil) ;setq (setq e2 T) ;setq (while (and e2 (or (= (getvar "errno") 7) (not (member ent2type lsValid))) ) (setvar "errno" 0) (setq e2 (entsel "\nSelect second object: ")) ;setq (if e2 (progn (setq ent2 (car e2)) ;setq (setq pickpt2 (osnap (cadr e2 ) "_nea")) (setq ent2list (entget ent2)) ;setq (setq ent2Type (cdr (assoc 0 ent2list)) ;setq bLayerUnLocked (acet-layer-locked (cdr (assoc 8 ent2list))) ;setq bCoplanar (acet-exfillet-bCoplanar ent2)) (if (and (member ent2Type lsValid) (not bLayerUnLocked) bCoplanar) ;here is where the second pick is valid and we can do our thing (progn (setvar "clayer" (cdr (assoc 8 entlist))) (setq Color (cdr (assoc 62 entlist))) ;setq (setq Linetype (cdr (assoc 6 entlist))) ;setq (if Color (setvar "cecolor" (itoa Color)) ) (if Linetype (setvar "celtype" Linetype) ) (acet-exfillet-fillet) );progn ;else if the second object was on a locked layer or was not a valid entity. (progn (cond ( bLayerUnLocked (princ "\nThe object is on a locked layer.")) ( (not bCoplanar) (princ "\nObject is not parallel to the current UCS.")) ((not (member ent2type lsValid)) (princ "\nRequires 2 lines, arcs, circles, plines, ellipses, splines, rays or xlines.")) (t "\nUnknown error.") );cond (setvar "errno" 7) ;telks the loop to ask again. );progn ) ;if );progn );if ;(setvar "errno" 0) ;;;0 breaks out of the loop. );while );progn ;;;else the the first entity was either on a locked layer or it was an invlid object.... (cond ( bLayerUnLocked (princ "\nThe object is on a locked layer.")) ( (not bCoplanar) (princ "\nObject is not parallel to the current UCS.")) ((not (member enttype lsValid)) (princ "\nRequires 2 lines, arcs, circles, plines, ellipses, splines, rays or xlines.")) (t "\nUnknown error.") );cond ) ;if (setvar "errno" 7) (redraw ent 4) ) ;defun optUserpick (defun acet-exfillet-PlinetoCurve( ent ent2 pickpt1 pickpt2 ent2Type / ss eLast entFillet lsWidthThick subentpt1 ) ;(print pickpt1) ;(command "_.undo" "_be") (command "_.undo" "_m") (setq lsWidthThick (acet-exfillet-getwidth-thickness ent)) (command "_.explode" ent ) ;;;ent is assumed to be the pline (setq ss (ssget "_P")) ;setq (setq eLast (entlast)) ;setq (setq subentpt1 (car (nentselp pickpt1))) ;setq (command "_.fillet" pickpt1 pickpt2) (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting (progn (cond ;;;if nothing new was created and we have either an arc or a line and trim mode is set to 2. ( (and (equal eLast (entlast)) (or (= ent2Type "ARC") (= ent2Type "LINE")) (= (acet-exfillet-gettrim) 2)) (progn ;(command "_.ucs" "_ob" subentpt1 ) (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick)) (command "_.pedit" ent2 "_Y" "_W" (rtos (car lsWidthThick)) "_J" ent "" "_X") ;;;then pedit join it all together ;(command "_.ucs" "_P") (command "_.erase" ss "") );progn );this condition ;;;if something was created and trimmode is set to join ( (and (not (equal eLast (entlast))) (or (= ent2Type "ARC") (= ent2Type "LINE")) (= (acet-exfillet-gettrim) 2)) (progn (setq entFillet (entlast)) ; (command "_.ucs" "_ob" subentpt1 ) (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick)) (command "_.pedit" entFillet "_Y" "_W" (rtos (car lsWidthThick)) "_J" ent ent2 "" "_X") ;;;then pedit join it all together ; (command "_.ucs" "_p" ) (command "_.erase" ss "") );progn ) ;;;if something was created but the second entity is not joinable... ( (and (not (equal eLast (entlast))) (not (or (= ent2Type "ARC") (= ent2Type "LINE"))) (= (acet-exfillet-gettrim) 2)) (progn (setq entFillet (entlast)) ;(command "_.ucs" "_ob" subentpt1 ) (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick)) (command "_.pedit" entFillet "_Y" "_J" ent "" "_X") ;;;then pedit join the fillet and the pline together. ;(command "_.ucs" "_p") (command "_.erase" ss "") );progn ) ( t (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick))) );cond ;(command "_.undo" "_end") (setq iUndo (1+ iUndo)) ;setq (setvar "errno" 0) );progn ;;else the fillet failed.... (progn (command nil) ;;;force us out of the "select second object" prompt by hitting the 1st entity again. ;(command "_.undo" "2");;;this might need to be changed to an undo 3 (command "_.undo" "_B") (setvar "errno" 7) ;;;errno of 7 means loop it );progn );if nil ;(setq e2 nil) ;setq ) ;defun () (defun acet-exfillet-fillet ( ) (cond ;;let the special casing begin.... ((and (wcmatch entType "*POLYLINE") (member ent2Type lsBugfix)) ;if ent1 is pline and other is on bugfix list. (setq e2 (acet-exfillet-PlinetoCurve ent ent2 pickpt1 pickpt2 ent2Type) ) ) ((and (wcmatch ent2Type "*POLYLINE") (member entType lsBugfix)) ;if ent2 is pline and other is on bugfix list (setq e2 (acet-exfillet-PlinetoCurve ent2 ent pickpt2 pickpt1 entType)) ) ((and (= entType "LWPOLYLINE") (equal ent ent2)) ;if it's two segments on the same lwpolyline... (progn ; (alert "2 segments on lwpoly.") ;(command "_.undo" "_be") (command "_.undo" "_m") (command "_.convertpoly" "_H" ent "") (command "_.fillet" pickpt1 pickpt2) (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting (progn (command "_.convertpoly" "_L" ent "") ;(command "_.undo" "_end") (setq iUndo (1+ iUndo)) ;setq (setq e2 nil) ;setq (setvar "errno" 0) ;;means we succeeded and can break out of the loop );progn ;;else (progn (command nil) ;;;force us out of the "select second object" prompt ;(command "_.undo" "1") ; changed this line (command "_.undo" "_B") (command "_.convertpoly" "_L" ent "") ;and this line to fix P1 AutoCAD bug. (setvar "errno" 7) ;;;errno of 7 means something went wrong on the second object prompt );progn );if );progn );this case ((and (wcmatch ent2Type "*POLYLINE") (wcmatch entType "*POLYLINE")(not (equal ent ent2))) ;if they are both plines (acet-exfillet-PlinetoPline) );this case ( T (progn (command "_.fillet" pickpt1 pickpt2) (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting (progn (setq iUndo (1+ iUndo)) ;setq (setq e2 nil) ;setq (setvar "errno" 0) );progn ;else (progn (command nil) ;(command "_.undo" "1") (command "_.undo" "_B") (setvar "errno" 7) ) ;progn );if );progn );default -- just fillet 'em );cond );end defun (defun acet-exfillet-getwidth-thickness (e / elist rWidth this40 this41 SKIPLOOP rThickness ) ;;;Pass in the entity list for a pline and this will return a list of ;;;the widths of the various segments. This is called by acet-exfillet-plinetopline (setq rWidth nil) (setq elist (entget e)) (setq rThickness (cdr (assoc 39 elist))) ;setq (if (= rThickness nil) (setq rThickness 0.0) ;setq ) ;if (cond ((= (cdr(assoc 0 elist)) "LWPOLYLINE") (progn (setq rWidth (cdr (assoc 43 elist))) ;setq (if (= rWidth nil) (setq rWidth 0.0) ;setq ) ;if );progn ) ((= (cdr(assoc 0 elist)) "POLYLINE") (progn (setq e (entnext e)) ;skip to the first vertex (setq elist (entget e)) (setq this40 (assoc 40 elist)) ;setq (setq this41 (assoc 41 elist)) ;setq (setq rWidth (cdr this40 )) ;setq (if (not (= rWidth (cdr this41))) (progn (setq rWidth 0.0) ;setq (setq SKIPLOOP T) ;setq );progn (setq SKIPLOOP nil) ;setq ) ;if (while (and (= (cdr (assoc 0 elist)) "VERTEX") (= SKIPLOOP T)) ;(print elist)(terpri) (if (or (not (= (cdr this40) rWidth)) (not (= (cdr this41) rWidth))) (progn (setq rWidth 0.0) ;setq (setq SKIPLOOP T) ;setq );progn ) ;if (setq e (entnext e)) (setq elist (entget e)) (setq this40 (assoc 40 elist)) ;setq (setq this41 (assoc 41 elist)) ;setq );while );progn );this cond (t (princ "\nMust pass a POLYLINE or LWPOLYLINE to (acet-exfillet-getwidth-thickness).")) );cond (list rWidth rThickness) );defun (defun acet-exfillet-optTrim ( / iTrim sDefault ans ) ;(command "_.undo" "_be") (command "_.undo" "_m") (setq iTrim (acet-exfillet-gettrim)) ;setq (cond ((= iTrim 0) (setq sDefault "No trim")) ((= iTrim 1) (setq sDefault "Trim")) ((= iTrim 2) (setq sDefault "Join")) ;setq ) ;if (initget "Join Trim Notrim") (setq ans (getkword (acet-str-format "\nEnter Trim mode option [Join/Trim/No trim] <%1>: " sDefault ))) ;setq ;(setq ans (getkword (strcat "\nEnter Trim mode option [Join/Trim/No trim] <" sDefault ">: " ))) ;setq (cond ((= ans "Join") (acet-exfillet-settrim 2)) ((= ans "Trim") (acet-exfillet-settrim 1)) ((= ans "Notrim") (acet-exfillet-settrim 0)) ( t (acet-exfillet-settrim iTrim)) );cond ;(command "_.undo" "_end") ;setq (setq iUndo (1+ iUndo)) ;setq (setvar "errno" 7) ) ;defun optTrim (defun acet-exfillet-settrim ( iTrim / ) (if (or (< iTrim 0)(> iTrim 2)) (progn (princ "\nACET_TRIMMODE value must be in the range of 0 to 2.") nil ;return nil if failed.... );progn ;;else (progn (acet-setvar (list "ACET-TRIMMODE" iTrim 2)) ;set the bns variable in the registry (if (or (= iTrim 0)(= iTrim 1)) ;;if the value is 0 or 1 (setvar "TRIMMODE" iTrim) ;;set ACAD's the same else (setvar "TRIMMODE" 1) ; (setvar "TRIMMODE" (getvar "TRIMMODE")) ;; set it to 1 NO! do nothing ) ;if T ;return true because all is well.... );progn ) ;if ) ;defun acet-exfillet-settrim (defun acet-exfillet-gettrim ( / iTrim) (setq iTrim (acet-getvar (list "ACET-TRIMMODE" 2))) ;setq (if (or (not iTrim) (and (or (= iTrim 0) (= iTrim 1)) (not (= iTrim (getvar "TRIMMODE"))) ) ;and );or ;(progn (setq iTrim (getvar "TRIMMODE")) ;(alert "\nACET-TRIMMODE and TRIMMODE were out of whack.") ;;;rewhack 'em ) ;if iTrim ) ;defun acet-exfillet-gettrim (defun acet-exfillet-restorepline ( ss subentpt lsWidthThickness / ) ;;;Pass this function a selection set of lines and it will join them together and slap the width back on them. ;(command "_.ucs""_OB" subentpt) (command "_.pedit" subentpt "_Y" "_J" ss "" "_w") (if (> (car lsWidthThickness) 0.0000000) (command (rtos (car lsWidthThickness)) "_X") (command "0.0" "_X") );if (if (> (cadr lsWidthThickness) 0.00000000) (command "_.change" (entlast) "" "_P" "_T" (rtos (cadr lsWidthThickness))"") ) ;if ;(command "_.ucs" "_p") (entlast) ;return the ent name of the pline we just joined together, );defun (defun acet-exfillet-PlinetoPline ( ;|ent ent2 pickpt1 pickpt2|; / lsWidthThick1 lsWidthThick2 eLast ss ss2 entFillet subentpt1 subentpt2 ) ; (alert "currently filleting two separate plines") ;(command "_.undo" "_be") (command "_.undo" "_m") (setq lsWidthThick2 (acet-exfillet-getwidth-thickness ent2) ) ;setq Get the width info for each pline (command "_.explode" ent2 ) ;explode (setq ss2 (ssget "_P")) ;setq ;stash it into a selection set ;;;adding new code to store width... (setq lsWidthThick1 (acet-exfillet-getwidth-thickness ent) ) ;setq (command "_.explode" ent ) (setq ss (ssget "_P")) ;setq (setq eLast (entlast)) ;setq ;(print pickpt1) ;(print pickpt2) (setq subentpt1 (car (nentselp pickpt1))) ;setq (setq subentpt2 (car (nentselp pickpt2))) (command "_.fillet" pickpt1 pickpt2);;check to see if it succeeded (no "radius too large" errors) (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting (progn (cond ;;if trimmode != notrim and there is not a new segment to add. ((and (equal eLast (entlast)) (not(= (acet-exfillet-gettrim) 0))) (progn ;(command "_.ucs" "_ob" subentpt1 ) (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1)) (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2)) (if (= (acet-exfillet-gettrim) 2) (command "_.pedit" ent "_J" ent ent2 "" "_X") );if ;(command "_.ucs" "_p" ) (command "_.erase" ss ss2 "") );progn ) ;;if trimmode != notrim and there is a new segment to add... ((and (not (equal eLast (entlast))) (not(= (acet-exfillet-gettrim) 0))) (progn (setq entFillet (entlast)) ;setq (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1)) (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2)) (if (= (acet-exfillet-gettrim) 2) (command "_.pedit" entFillet "_Y" "_W" (rtos (car lsWidthThick1)) "_J" ent ent2 "" "_X") ;apply width to fillet segment. );if (command "_.erase" ss ss2 "") );progn ) (T (progn (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1)) (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2)) );progn ) ) ;cond ;(command "_.undo" "_end") (setq iUndo (1+ iUndo)) ;setq (setq e2 nil) ;setq (setvar "errno" 0) );progn ;else (progn (command nil) ;;;force us out of the "select second object" prompt ;(command "_.undo" "3") (command "_.undo" "_b") (setvar "errno" 7) ;;;errno of 7 means something went wrong );progn );if ) ;defun acet-exfillet-PlinetoPline (defun acet-Exfillet-bCoplanar ( e / elist v_ent v_ucs ) ;;;takes an entity name and returns true if it lies in the plane of the current UCS. (setq elist (entget e) v_ent (cdr (assoc 210 elist)) v_ucs (acet-geom-cross-product (getvar "ucsxdir") (getvar "ucsydir")) );setq (equal v_ent v_ucs 0.00000001) ; return T if the entity is coplanar and nil if it is not. ) ;defun acet-exfillet-b-coplanar (princ)