Draws revision clouds with optional bulge size, undo, hatching or revision delta


;; Draws revision clouds with optional bulge size, undo, hatching or revision delta.
;; Saved from: http://www.cadtutor.net/forum/showthread.php?13081-Updated-Drawing-Notification&highlight=revison+clouds
;; Slightly modified by Igal Averbuh 2018 (added Solid and Cross Hatch options for revision clouds)
(defun c:DWL ( / rev ins stpt obpt np dist ang distsf count hatch? bulgesf np1 vOAttdia fOError undocount lstpt cloud switcher)
(setq fOerror *error*)
(defun *error* (sErr)
(if (or (= sErr "Function cancelled")
(= sErr "quit / exit abort")
)
(princ)
(princ (strcat "\nError: " sErr))
)
(setq *error* fOError)
(princ)
)
(setvar "cmdecho" 0)
(if (equal 0.0 (getvar "dimscale") 0.00001)
(setvar "dimscale" 1)
)
(princ "\nNote: Clouds must go in a counter-clockwise direction")
(initget 1)
(setq stpt (getpoint "\nFrom Point: ")
lstpt stpt
np stpt
bulgesf 0.25 ; default bulge scale factor is "medium"
np1 ""
undocount 0
switcher 0)
(command "_.undo" "_begin")
(command "_.pline" stpt "_width" 0 0 "_arc")
(prompt "\n")
(while (and np (/= np1 stpt))
(while (not (listp np1))
(initget 0 "Small Medium Large eXtra Close Undo")
(setq np1 (getpoint lstpt "\nSmall/Medium/Large/eXtra-large/Close/Undo : "))
(if (not (listp np1))
(cond ; set scale factor for cloud bulges
((= np1 "Small")(setq bulgesf 0.25))
((= np1 "Medium")(setq bulgesf 0.5))
((= np1 "Large")(setq bulgesf 1.0))
((= np1 "eXtra")(setq bulgesf 2.0))
((= np1 "Close")(setq np stpt
np1 stpt))
((= np1 "Undo")
(if (< 0 undocount); can't backup beyond beginning...
(progn
(command "_undo")
(setq
lstpt (getvar "lastpoint")
undocount (1- undocount)
)
(if (= 0 undocount) (command "_arc"))
)
(princ "\nAll cloud segments already undone.")
)
)
)
(setq np np1)
)
)
(if (= np "")(setq np nil))
(if np
(setq dist (distance lstpt np)
ang (angle lstpt np))
(setq dist nil)
)
(if dist
(progn
(if (= dist (* 2 (* (getvar "dimscale") bulgesf)))
(progn
(setq distsf (fix (/ dist (* (getvar "dimscale") bulgesf))) count distsf)
(while (> count 0)
(setq np (polar lstpt ang (/ dist distsf)))
(command "s" (polar (polar lstpt ang (/ dist (* distsf 2)))
(if (zerop switcher)
(- ang (/ pi 2))
(+ ang (/ pi 2))
)
(/ dist (* distsf 4))) np)
(setq lstpt np
count (1- count)
undocount (1+ undocount)
switcher (abs (1- switcher)))
)
)
)
)
)
(if (/= np1 stpt)(setq np1 ""))
)
(command "")
(setq cloud (entlast))
(if (< 0 undocount)
(progn
(while (/= hatch? "None")
(initget 0 "Pline Offset Rev Solid Cross")
(setq hatch? (getkword "\nAditional Options [Pline/Offset/Rev delta/http://www.cadtutor.net/forum/showthread.php?13081-Updated-Drawing-Notification&highlight=revison+clouds] : "))
(cond
((= hatch? "Cross")(command "hatch" "ansi37,N" (* 1.0 (getvar "dimscale")) "0" "last" ""))
((= hatch? "Solid")(command "hatch" "solid,N" (* 1.0 (getvar "dimscale")) "45" "last" ""))
((= hatch? "Offset")(command "offset" (* 0.015 (getvar "dimscale")) cloud (getvar "limmax") "")(setq cloud (entlast)))
((= hatch? "Pline")(command ".pedit" cloud "w" "0.02" ""))
((= hatch? "Rev")
(setq rev (getstring "\n Revision Number? : "))
(if (= rev "")(setq rev "-"))
(setq ins (getpoint "\nPick delta insertion point: "))
(entmake (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(67 . 0)'(410 . "Model")
'(100 . "AcDbPolyline")'(90 . 2)'(70 . 1)'(43 . 0.0)'(38 . 0.0)'(39 . 0.0)
(cons 10 (polar ins (/ pi 2)(* 0.29 (getvar "dimscale"))))'(42 . 0.0)
(cons 10 (polar ins (* 7 (/ pi 6))(* 0.29 (getvar "dimscale"))))'(42 . 0.0)
(cons 10 (polar ins (* 11(/ pi 6))(* 0.29 (getvar "dimscale"))))'(42 . 0.0)
'(210 0.0 0.0 1.0)))
(entmake (list '(0 . "TEXT")'(100 . "AcDbEntity")'(67 . 0)'(410 . "Model")'(100 . "AcDbText")
(cons 10 (polar ins (/ pi 2) (* 0.012 (getvar "dimscale"))))
(cons 40 (* 0.125 (getvar "dimscale")))(cons 1 (strcase rev))'(50 . 0.0)
'(41 . 0.85)'(51 . 0.0)'(7 . "STANDARD")'(71 . 0)'(72 . 4)
(cons 11 (polar ins (/ pi 2) (* 0.012 (getvar "dimscale"))))
'(210 0.0 0.0 1.0)'(100 . "AcDbText")'(73 . 2)))
)
(t (setq hatch? "None"))
)
)
)
)
(command "_.undo" "_end")
(setq *error* fOError)
(princ)
)
(princ)
(c:dwl)

Advertisements

Separate Layout objects to individual new layouts


;;; Separate Layout objects to individual new layouts
;;; Created by Igal Averbuh 2018. Dedicated to Topaz LTD
(princ "\rType LS to Invoke")
(defun c:PB ()
(princ "\rPasteBase: (0.0,0.0,0.0) ")

(command "._pasteclip" "0,0,0")

)

(defun c:LS (/ i )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
; (LM:endundo (LM:acdoc))
(setvar 'maxactvp 64)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
(setvar 'maxactvp 64)
)
(princ)
)

;; 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)
)

(while

(setvar 'maxactvp 2)

(princ "\rSelect Layout objects to separate: ")

(setq curtab (getvar 'ctab))

(setq sset (ssget))

(vl-cmdf "_cutclip" sset "")

(setq i (getstring "\nEnter New Layout Name: "))

(command "._layout" "_new" i)

(setvar "ctab" i)

(c:pb)

(setvar "ctab" curtab)

)

)

;(c:ls) ;; Don't invoke - program not working in this case

Delete all objects in MODEL space which are not present in any of the viewports


;;; Delete all objects in MODEL space which are not present in any of the viewports.
;;; Created by mailmaverick
;;; Saved from: https://www.theswamp.org/index.php?topic=46981.0
(defun c:DV ()
(setq ssview (ssadd))
(setvar 'ctab "MODEL")
(setq app (vlax-get-acad-object))
(vlax-for lay ; for each layout
(vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
(setq id1 nil) ; ignore the first vp
(if (eq :vlax-false (vla-get-modeltype lay))
(progn (vlax-for obj (vla-get-block lay) ; for each obj in layout
(if (and (= (vla-get-objectname obj) "AcDbViewport")
(or id1 (not (setq id1 t))) ; ignore first viewport because that is the viewport tab itself
)
(progn (vla-GetBoundingBox obj 'LPVP 'UPVP)
(setq LPVP (vlax-safearray->list LPVP))
(setq UPVP (vlax-safearray->list UPVP))
(setq LPMODEL (PCS2WCS LPVP (vlax-vla-object->ename obj)))
(setq UPMODEL (PCS2WCS UPVP (vlax-vla-object->ename obj)))
(setq minx (car LPMODEL))
(setq maxx (car UPMODEL))
(setq miny (cadr LPMODEL))
(setq maxy (cadr UPMODEL))
(setq pt1 (list minx miny))
(setq pt2 (list maxx miny))
(setq pt3 (list maxx maxy))
(setq pt4 (list minx maxy))
(vla-zoomwindow app (vlax-3d-point pt1) (vlax-3d-point pt3))
(if (setq ss (ssget "_CP" (list pt1 pt2 pt3 pt4) (list (cons 410 "MODEL"))))
(setq ssview (kdub:ssunion ssview ss))
)
)
)
)
)
)
)
(setq ssall (ssget "_X" (list (cons 410 "MODEL"))))
(setq sstodel (kdub:sssubtract ssall ssview))
(repeat (setq n (sslength sstodel)) (setq ent (ssname sstodel (setq n (1- n)))) (entdel ent))
)

;;; Union of two selection sets
(defun kdub:ssunion (ss1 ss2 / ss index)
;;; Source : http://www.theswamp.org/index.php?topic=46652.0
(setq ss (ssadd))
(cond ((and ss1 ss2)
(setq index -1)
(repeat (sslength ss1) (ssadd (ssname ss1 (setq index (1+ index))) ss))
(setq index -1)
(repeat (sslength ss2) (ssadd (ssname ss2 (setq index (1+ index))) ss))
)
(ss1 (setq ss ss1))
(ss2 (setq ss ss2))
(t (setq ss nil))
)
ss
)

;; Subtracts one selection set from another and returns their difference
;; NOT optimal because it changes the previous/last selection set.
(defun kdub:sssubtract (ss1 ss2 / ss)
;;; Source : http://www.theswamp.org/index.php?topic=46652.0
(cond ((and ss1 ss2) (vl-cmdf "._Select" ss1 "_Remove" ss2 "") (setq ss (ssget "_P")))
(ss1 (setq ss ss1))
(t (setq ss nil))
)
ss
)

(defun PCS2WCS (pnt ent / ang enx mat nor scl)
;;; Source : http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Auto-Update-of-XY-coord-in-Model-Space-onto-Paper-Space-Layout/td-p/4591789/page/2
(setq pnt (trans pnt 0 0)
enx (entget ent)
ang (- (cdr (assoc 51 enx)))
nor (cdr (assoc 16 enx))
scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
mat (mxm (mapcar (function (lambda (v) (trans v 0 nor t))) '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)))
(list (list (cos ang) (- (sin ang)) 0.0) (list (sin ang) (cos ang) 0.0) '(0.0 0.0 1.0))
)
)
(mapcar '+
(mxv mat (mapcar '+ (vxs pnt scl) (vxs (cdr (assoc 10 enx)) (- scl)) (cdr (assoc 12 enx))))
(cdr (assoc 17 enx))
)
)

;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix

(defun trp (m) (apply 'mapcar (cons 'list m)))

;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm (m n) ((lambda (a) (mapcar '(lambda (r) (mxv a r)) m)) (trp n)))

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv (m v) (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m))

;; Vector x Scalar - Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs (v s) (mapcar '(lambda (n) (* n s)) v))

(c:dv)

Multiline Fillet with increment fillet Radius and option to “Unexplode” connected lines to Polylines


;;; 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 ")

Change Color of All Layers to user defined color with change color Color of ALL entities in the drawing to ByLayer


;;; Change Color of All Layers to user defined color with change color Color of ALL entities in the drawing to ByLayer
;;; Main routine Created by Igal Averbuh 2017
;;; Subroutine AllColorBylayer.lsp created by Kent Cooper

(vl-load-com)
;; AllColorBylayer.lsp [command name: ACB]
;; To change the Color of ALL entities in the drawing, including those nested in
;; Block definitions [but not Xrefs] and Dimension/Leader parts, to ByLayer.
;; Kent Cooper, 27 February 2014, expanding on some elements by p_mcknight

(defun C:ACB ; = All to Color Bylayer
(/ cb ent obj blk subent)
(defun cb () ; = force Color(s) to Bylayer
(setq obj (vlax-ename->vla-object ent))
(vla-put-color obj 256); ByLayer
(if (wcmatch (vla-get-ObjectName obj) "*Dimension,*Leader")
(foreach prop '(DimensionLineColor ExtensionLineColor TextColor)
;; not all such entity types have all 3 properties, but all have at least one
(if (vlax-property-available-p obj prop)
(vlax-put obj prop 256); ByLayer
); if
); foreach
); if
); defun -- cb
;; Top-level entities:
(setq ent (entnext))
(while ent
(cb)
(setq ent (entnext ent))
); while
;; Nested entities in this drawing's Block definitions:
(setq blk (tblnext "block" t))
(while blk
(if (= (logand 20 (cdr (assoc 70 blk))) 0); not an Xref [4] or Xref-dependent [16]
(progn
(setq ent (cdr (assoc -2 blk)))
(while ent
(cb)
(setq ent (entnext ent))
); while
); progn
); if
(setq blk (tblnext "block"))
); while

(princ)
); defun

(defun c:cch1 (/ c1 c2 )
(vl-load-com)
(setq c2 (getint " What is the new color: "))
(vlax-for layer
(vla-get-Layers
(vla-get-ActiveDocument
(vlax-get-Acad-Object))) (vla-put-Color layer c2))
(prin1)
)

(defun c:cch (/ )
(c:acb)
(c:cch1)
)
;(c:cch)

Convert All RGB color layers to ACI index


;;; Convert All RGB colour layers to ACI index
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?65645-Convert-from-index-colours-to-true-colours
(defun C:LRB ( )
(Color-to-ACIcolor)
; (command "_.Regenall")
(princ)
)
(defun Color-to-ACIcolor (/ txt count *error*)
(defun *error* (msg)
(princ msg)
(mip:layer-status-restore)
(princ)
) ;_ end of defun
(mip:layer-status-save)
(vlax-for Blk (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-blocks
(setq count 0)
(grtext -1
(setq txt
(strcat "Inspecting objects: "
(vla-get-name Blk)
)
)
) ;_ end of grtext
(if (= (vla-get-isxref Blk) :vlax-false)
(progn
(vlax-for Obj Blk
(setq count (1+ count))
(if (zerop (rem count 10))
(grtext -1 (strcat txt " : " (itoa count)))
)
(if (and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'Color)
)
(vla-put-color Obj (vla-get-color Obj))
)
) ;_ end of vlax-for
) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
(vlax-for Lay (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-put-color Lay (vla-get-color Lay))
)
(mip:layer-status-restore)
)
(defun mip:layer-status-restore ()
(foreach item *PD_LAYER_LST*
(if (not (vlax-erased-p (car item)))
(vl-catch-all-apply
'(lambda ()
(vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
(vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of if
) ;_ end of foreach
(setq *PD_LAYER_LST* nil)
) ;_ end of defun

(defun mip:layer-status-save ()
(setq *PD_LAYER_LST* nil)
(vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(setq *PD_LAYER_LST* (cons (list item
(cons "freeze" (vla-get-freeze item))
(cons "lock" (vla-get-lock item))
) ;_ end of cons
*PD_LAYER_LST*
) ;_ end of cons
) ;_ end of setq
(vla-put-lock item :vlax-false)
(if (= (vla-get-freeze item) :vlax-true)
(vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
) ;_ end of vlax-for
) ;_ end of defun
(princ)
(c:lrb)

Convert selected ACI color layers to RGB index


;;; Convert selected ACI colour layers to RGB index
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?65645-Convert-from-index-colours-to-true-colours
(defun C:LRC ( / lay truecol aci R G B lm i)
(vl-load-com)
(setq lm (getstring "\nLayer(s) to convert to truecolor (*=all, layer name or mask) : ") i 0)
(if (= lm "") (setq lm "*"))
(vlax-for lay (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(if (wcmatch (vla-get-name lay) lm)(progn
(setq truecol (vla-get-truecolor lay))
(if (= (vla-get-ColorMethod truecol) acColorMethodByACI) ; ACI?
(progn
(setq aci (vla-get-ColorIndex truecol))
(vla-put-ColorMethod truecol acColorMethodByRGB)
(vla-put-ColorIndex truecol aci)
(setq R (vla-get-red truecol))
(setq G (vla-get-green truecol))
(setq B (vla-get-blue truecol))
(vla-setRGB truecol R G B)
(vla-put-truecolor lay truecol)
(setq i (1+ i))
)
)
))
) ; vlax
(princ (strcat "\n" (itoa i) " layer(s) converted."))
(princ)
)
(c:lrc)

Selection of block references according to attribute labels and their specific values


;; Selection of block references according to attribute labels and their specific values
;; Saved from:
;; http://cadxp.com/index.php?/topic/37573-faire-une-selection-dun-bloc-en-fonction-de-deux-de-ses-attributs/page__pid__207342#entry207342
;;
;; Routine by VDH-Bruno le: 28/05/2013
;; ======================================================================

(defun c:fa (/ lstTagAtt tagAtt doc ss1 ss2 inclu-p inputval)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
ss2 (ssadd)
)

(vlax-for b (vla-get-Blocks doc)
(if (and (= (vla-get-IsLayout B) :vlax-false)
(= (vla-get-IsXref B) :vlax-false)
(not (wcmatch (vla-get-Name B) "*|*"))
)
(vlax-for o b
(and (= (vla-get-ObjectName o) "AcDbAttributeDefinition")
(not (member (setq tagAtt (vla-get-TagString o)) lstTagAtt))
(setq lstTagAtt (cons tagAtt lstTagAtt))
)
)
)
)

(setq
lstTagAtt (listbox

"Attribute Fields/Columns "
"Select the Attribute Fields/Columns to Filter ... "

(mapcar 'cons (setq lstTagAtt (vl-sort lstTagAtt '<)) lstTagAtt)
2
)
)

(defun inputval (l)
(if l
(cons
(cons
(car l)

(getstring (strcat "Value to search for the Fields/Columns " (car l) ": ")

)
)
(inputval (cdr l))
)
)
)

(cond
((setq lstTagAtt (inputval lstTagAtt))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(princ "\nSelect the Blocks or : " )

(or (ssget (list '(0 . "INSERT") '(66 . 1)))
(ssget "_X" (list '(0 . "INSERT") '(66 . 1)))
)

(defun inclu-p (l1 l2)
(cond ((null l1) t)
((member (car l1) l2) (inclu-p (cdr l1) l2))
(t nil)
)
)

(vlax-for b (setq ss1 (vla-get-ActiveSelectionSet doc))
;; vיrifie que les critטres de filtres liste (Tag .Val) sont compris dans le bloc
(if (inclu-p
lstTagAtt
;; Liste les couples (Tag .Val) de la rיfיrence de bloc
(mapcar
'(lambda (x) (cons (vla-get-TagString x) (vla-get-TextString x)))
(vlax-invoke b 'GetAttributes)
)
)
(ssadd (vlax-vla-object->ename B) ss2)
)
)
(vla-delete ss1)
(sssetfirst nil ss2)
)
)
(princ)
)

(defun str2lst (str sep / pos)
(if (setq pos (vl-string-search sep str))
(cons (substr str 1 pos)
(str2lst (substr str (+ (strlen sep) pos 1)) sep)
)
(list str)
)
)

;

(defun ListBox (title msg keylab flag / tmp file dcl_id choice)
(setq tmp (vl-filename-mktemp "tmp.dcl")
file (open tmp "w")
)
(write-line
(strcat "ListBox:dialog{label=\"" title "\";")
file
)
(if (and msg (/= msg ""))
(write-line (strcat ":text{label=\"" msg "\";}") file)
)
(write-line
(cond
((= 0 flag) "spacer;:popup_list{key=\"lst\";")
((= 1 flag) "spacer;:list_box{key=\"lst\";")
(T "spacer;:list_box{key=\"lst\";multiple_select=true;")
)
file
)
(write-line "}spacer;ok_cancel;}" file)
(close file)
(setq dcl_id (load_dialog tmp))
(if (not (new_dialog "ListBox" dcl_id))
(exit)
)
(start_list "lst")
(mapcar 'add_list (mapcar 'cdr keylab))
(end_list)
(action_tile
"accept"
"(or (= (get_tile \"lst\") \"\")
(if (= 2 flag) (progn
(foreach n (str2lst (get_tile \"lst\") \" \")
(setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice)))
(setq choice (reverse choice)))
(setq choice (nth (atoi (get_tile \"lst\")) (mapcar 'car keylab)))))
(done_dialog)"
)
(start_dialog)
(unload_dialog dcl_id)
(vl-file-delete tmp)
choice
)

(c:fa)

Select all blocks with selected attribute


;;; Select all blocks with selected attribute
;;; Saved from: https://forums.autodesk.com/t5/autocad-forum/select-through-attribute-value/td-p/2227193

(defun c:fa (/ att elst tag val ss1 ss2 n ent)
(and
(setq att (car (nentsel "\nSelect source attribute: ")))
(setq elst (entget att))
(setq tag (cdr (assoc 2 elst))
val (cdr (assoc 1 elst))
ss2 (ssadd)
)
(setq ss1 (ssget "_X"
(list '(0 . "INSERT")
(assoc 2 (entget (cdr (assoc 330 elst))))
)
)
)
(repeat (setq n (sslength ss1))
(setq ent (ssname ss1 (setq n (1- n)))
att (entnext ent)
)
(while (= (cdr (assoc 0 (setq elst (entget att)))) "ATTRIB")
(if (and (= (cdr (assoc 2 elst)) tag)
(= (cdr (assoc 1 elst)) val)
)
(ssadd ent ss2)
)
(setq att (entnext att))
)
)
(sssetfirst nil ss2)
)
(princ)
)
(c:fa)

Draw line and a text with layer name and description for each layer (Layer Legend)


;;; Draw line and a text with layer name and description for each layer (Layer Legend)
;;; Created by HasanCAD
;;; Saved from: https://www.theswamp.org/index.php?topic=53481.0

(defun c:LLD () (c:LayerLegend))

(defun c:LayerLegend ( / df i ln p1 pt sp ) ;; Lee Mac 2011
(if
(and
(setq pt (getpoint "\nSpecify Point for Legend: "))
(setq ln (* 100 (getvar 'TEXTSIZE))) ;(getdist "\nSpecify Length of Lines: " pt))
(setq pt (trans pt 1 0))
(setq i -1)
(setq sp (* 1.5 (getvar 'TEXTSIZE)))
)
(while (setq df (tblnext "LAYER" (null df)))
(setq ent (vlax-ename->vla-object (tblobjname "LAYER" (cdr (assoc 2 df)))))
(setq dsc (vlax-get-property ent 'Description))
(setq nm (vlax-get-property ent 'name))
(entmakex (list
(cons 0 "LINE")
(cons 8 (cdr (assoc 2 df)))
(cons 6 "ByLayer")
(cons 62 256)
(cons 10
(setq p1 (polar pt (* 1.5 pi) (* (setq i (1+ i)) sp)))
)
(cons 11 (polar p1 0. ln))
(cons 370 -1)
)
)

(entmakex (list (cons 0 "TEXT") ;***
(cons 1 (strcat (cdr (assoc 2 df)) " : " dsc)) ;* (the string itself)
(cons 6 "BYLAYER") ; Linetype name
(cons 7 (getvar 'TEXTSTYLE)) ;* Text style name, defaults to STANDARD, not current
(cons 8 (cdr (assoc 2 df))) ; layer
(cons 10 p1) ;* First alignment point (in OCS)
(cons 11 p1) ;* Second alignment point (in OCS)
(cons 39 0.0) ; Thickness (optional; default = 0)
(cons 40 (getvar 'TEXTSIZE)) ;* Text height
(cons 41 1.0) ; Relative X scale factor, Width Factor, defaults to 1.0
(cons 62 256) ; color
(cons 71 0) ; Text generation flags
(cons 72 0) ; Horizontal text justification type
(cons 73 1) ; Vertical text justification type
(cons 210 (list 0.0 0.0 1.0))
(cons 370 -1)
))
) )
(princ)
)
(c:lld)