;;; MultiLine Fillet with increment fillet Radius and option to "Unexplode" conected lines to Polylines
;;; Saved from: http://forums.augi.com/showthread.php?44929-Looking-for-a-routine-for-Multiple-Fillet
;;; Combined and slightly modified by Igal Averbuh 2017

;(princ "\nTo Unexplode Polilines use UP function")
;;; Unexplode Polilines
;;; Based on Lee Mak routines saved from: http://www.cadtutor.net/forum/showthread.php?92452-convert-lines-to-polyline-(where-endpoints-coincide)
;;; Combined by Igal Averbuh 2017

;;--------------------=={ Chain Selection }==-----------------;;
;; ;;
;; Prompts the user to select an object and generates a ;;
;; selection chain of all objects sharing endpoints with ;;
;; objects in the accumulative selection. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:pj ( / *error* sel val var )

(defun *error* ( msg )
(mapcar '(lambda ( a b ) (if b (setvar a b))) var val)
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel
(LM:ssget "\nPolyline was Unexploded "
'( "_:L"
(
(-4 . "<OR")
(0 . "LINE,ARC")
(-4 . "")
(-4 . "OR>")
)
)
)
)
(progn
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
)
(mapcar '(lambda ( a b c ) (if a (setvar b c))) val var '(0 1))
(command "_.pedit" "_m" sel "" "_j" "" "")
)
)
(*error* nil)
(princ)
)

(defun c:ccp ( / en fl in l1 l2 s1 s2 sf vl )
(setq sf
(list
'(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "")
'(-4 . "")
'(-4 . "<AND")
'(0 . "ELLIPSE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
(if (setq s1 (ssget "_X" sf))
(if (setq en (ssget "_+.:E:S" sf))
(progn
(setq s2 (ssadd)
en (ssname en 0)
l1 (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
)
(repeat (setq in (sslength s1))
(setq en (ssname s1 (setq in (1- in)))
vl (cons (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en) en) vl)
)
)
(while
(progn
(foreach v vl
(if (vl-some '(lambda ( p ) (or (equal (car v) p 1e-8) (equal (cadr v) p 1e-8))) l1)
(setq s2 (ssadd (caddr v) s2)
l1 (vl-list* (car v) (cadr v) l1)
fl t
)
(setq l2 (cons v l2))
)
)
fl
)
(setq vl l2 l2 nil fl nil)
)
)
)
(princ "\nNo valid objects found.")
)
(sssetfirst nil s2)
(princ)
)
(vl-load-com) (princ)

(defun c:up ( / )
(c:lio)
(while
(princ "\nSelect Polylines to Unexlode")
(c:ccp)
(c:pj)
)
)

;; Uniformly Scaled Block - Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
(if (vlax-property-available-p obj 'xeffectivescalefactor)
(setq s "effectivescalefactor")
(setq s "scalefactor")
)
(eval
(list 'defun 'LM:usblock-p '( obj )
(list 'and
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "y" s))
1e-8
)
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "z" s))
1e-8
)
)
)
)
(LM:usblock-p obj)
)

;; entlast - Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
(setq ent (entlast))
(while (setq tmp (entnext ent)) (setq ent tmp))
ent
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com)

;; LayerIsolateOnOff.lsp [command names: LIO, LUO]
;; To Isolate and Unisolate only the On-Off condition of Layers of selected objects.
;; LIO isolates Layers of selected objects, leaving those Layers on and turning all
;; other Layers off that are not already off. If repeated before LUO turns those
;; Layers back on, makes further isolations, to as many levels as desired.
;; LUO turns latest set of turned-off Layers back on, without undoing other Layer
;; options that may have been used under isolated conditions [as happens with
;; some (e.g. colors) if using AutoCAD's standard LAYERUNISO to return to un-
;; isolated conditions after using LAYISO]. When repeated, steps back through
;; as many isolations as were done with LIO [LAYISO can only step back once].
;; Kent Cooper, August 2011

(vl-load-com)

(defun liV (sub); = build Variable name with subtype and current integer ending
(read (strcat "li" sub (itoa liinc)))
); defun

(defun liG (sub); = Get what's in the above variable
(eval (read (strcat "li" sub (itoa liinc))))
); defun

(defun C:LIO (/ ss cmde laysel layname lion layobj); = Layer Isolate -- On-Off condition only
(prompt "\nSelect Layers to remain ON,")
(if (setq ss (ssget)); object selection
(progn
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(repeat (sslength ss); make list of Layer names to remain on
(setq laysel (cdr (assoc 8 (entget (ssname ss 0))))); Layer name
(if (not (member laysel lion)) (setq lion (cons laysel lion))); add if not already there
(ssdel (ssname ss 0) ss)
); repeat
(setq liinc (if liinc (1+ liinc) 1)); liinc is global; 1 for first time, etc.
(if
(set (liV "cur"); global variable(s), but need(s) to be:
(if (not (member (getvar 'clayer) lion)); nil if current Layer kept on
(vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer)))
); if
); set
(setvar 'clayer (nth 0 lion)); then - make some selected object's Layer current
); if
(while (setq layname (cdadr (tblnext "layer" (not layname)))); step through Layers
(if
(and
(not (member layname lion)); not among selected objects' Layers
(> (cdr (assoc 62 (tblsearch "layer" layname))) 0); currently on
); and
(progn
(setq layobj (vlax-ename->vla-object (tblobjname "layer" layname)))
(set (liV "off") (cons layobj (liG "off")))
; put in list of Layers turned off -- makes global variables lioff1, lioff2, etc.
(vla-put-LayerOn layobj 0); turn off
); progn
); if
); while
(prompt
(strcat
"\n"
(itoa (length lion))
" Layer(s) isolated, "
(itoa (length (liG "off")))
" Layer(s) turned off."
(if (liG "cur")
(strcat " Layer " (getvar 'clayer) " has been made current."); then
"" ; else - add nothing to prompt if current Layer remains on
); if
); strcat
); prompt
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNothing selected.")
); if
(princ)
); defun

(defun C:LUO (/ cmde lugone lucur); = Layer Unisolate -- On-Off condition only
(if (> liinc 0); at least one list of turned-off Layers exists
(progn ; then
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(foreach lay (liG "off"); latest numbered list
(if (vlax-vla-object->ename lay); still in drawing
(vla-put-LayerOn lay -1); then - turn on
(progn ; else
(vl-remove lay (liG "off")); to adjust number for prompt later
(setq lugone (if lugone (1+ lugone) 1)); quantity of no-longer-present Layers
); progn
); if
); foreach
(if ; restore Layer current at time of corresponding LIO if it was turned off
(and
(liG "cur"); nil if it wasn't
(vlax-vla-object->ename (liG "cur")); Layer still in drawing, even if renamed
); and
(progn
(setq lucur (vla-get-Name (liG "cur"))); present name if renamed since its LIO
(setvar 'clayer lucur); restore as current
); progn
); if
(prompt
(strcat
"\n"
(itoa (length (liG "off")))
" Layer(s) turned back on."
(if (liG "cur") ; corresponding LIO turned off current Layer at the time
(strcat ; then
"\nLayer "
(if (vlax-vla-object->ename (liG "cur")); still in drawing
(vla-get-Name (liG "cur")); then - name, even if renamed
"current at time of LIO purged, and not"
); if
" restored as current."
); strcat
"" ; else - add nothing if corresponding LIO kept current Layer on
); if
(if lugone (strcat "\n" (itoa lugone) " purged Layer(s) not turned back on.") "")
); strcat
); prompt
(set (liV "off") nil); clear list ending with latest integer in use
(set (liV "cur") nil); clear current-at-LIO-Layer-if-changed value with latest integer
(setq liinc (1- liinc)); increment downward for next-earlier list
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNo Layers to Unisolate."); else
); if
(princ)
); defun

;;; Helper function to get the point from pt1 perp to entity picked at point pt2
(defun GetPerpPoint (pt1 pt2 /)
(setvar "LASTPOINT" pt1)
(osnap pt2 "_perp")
) ;_ end of defun

;;; Helper function to get the distance from pt1 perp to entity picked at point pt2
(defun GetPerpDist (pt1 pt2 /)
(distance pt1 (GetPerpPoint pt1 pt2))
) ;_ end of defun

(setq MFillet:Inc "Yes") ;Remember increment fillet

;;; Fillet multiple lines by selecting with fences
(defun c:MF1 (/ ss1 ss2 n m en1 en2 pt1 pt2 ptlast rad rad1 cmd)
(setq cmd (getvar "CMDECHO")) ;Get value of CMDECHO
(setvar "CMDECHO" 0) ;Don't show prompts on command line
(command "_.UNDO" "_BEgin")
(setq rad (getvar "FILLETRAD")) ;Get the normal fillet radius
(while (/= (type pt1) 'List)
(princ (strcat "\nCurrent settings: Raduis = "
(rtos rad)
", Increment Fillet = "
MFillet:Inc
"\n"
) ;_ end of strcat
) ;_ end of princ
(initget "Radius Increment") ;Setup for keywords
(setq pt1 (getpoint "Select by fence-line 1st set of LINES [Radius/Increment]: ")) ;Get 1st point
(cond
((and (= pt1 "Radius")
(setq rad1 (getDist (strcat "New Radius : ")))
) ;_ end of and
(setq rad rad1)
)
((= pt1 "Increment")
(initget "Yes No")
(if (setq rad1 (getkword (strcat "Do you want to increment the radius? [Yes/No] : ")))
(setq MFillet:Inc rad1)
) ;_ end of if
)
) ;_ end of cond
) ;_ end of while
(setq pt2 (getpoint pt1 "2nd point of fence-line: ")
ss1 (ssget "F" (list pt1 pt2))
) ;_ end of setq
(setq pt1 (getpoint "Select by fence-line 2nd set of LINES: ")
pt2 (getpoint pt1 "2nd point of fence-line: ")
ss2 (ssget "F" (list pt1 pt2))
) ;_ end of setq
(setq n 0
m 0
rad1 0.0 ;Initialize the radius to add
) ;_ end of setq
(while (and ss1 ss2 (< n (sslength ss1)) (< m (sslength ss2)))
(setq en1 (ssname ss1 n)
pt1 (cadr (cadddr (car (ssnamex ss1 n))))
en2 (ssname ss2 m)
pt2 (cadr (cadddr (car (ssnamex ss2 m))))
) ;_ end of setq
(if (and ptlast (= MFillet:Inc "Yes"))
(setq rad1 (+ rad1 (GetPerpDist ptlast pt1)))
) ;_ end of if
(setvar "FILLETRAD" (+ rad rad1))
(command "_.FILLET" (list en1 pt1) (list en2 pt2))
(setq n (1+ n)
m (1+ m)
ptlast pt1
) ;_ end of setq
) ;_ end of while
(setvar "FILLETRAD" rad) ;Restore previous radius
(command "_.UNDO" "_End")
(setvar "CMDECHO" cmd) ;Restore prompts on command line
(princ)
) ;_ end of defun

(defun c:mf ( / )
(c:lio)
(c:mf1)
;(c:up)
(c:luo)
)
(c:mf)
(alert "\nTo Unexplode Polylines use UP function\nPress Esc button twice to interupt UP function\nAfter Polylines unexploding use LUO function to UnIsolate Layers ")

Advertisements