Copy selected objects into same place but in different (user defined) layer


;;; Copy selected objects into same place but in different (user defined) layer
;;; Based on routine created by BIGAL saved from: http://www.cadtutor.net/forum/showthread.php?98213-Copy-text-into-same-place-but-in-different-layer
;;; Deeply modified by Igal Averbuh 2018 (added option to copy any kind of objects and select layer to copy to)

(defun c:ccl ( / oldsnap ss x obj)
(setq oldsnap (getvar "osmode"))
(setvar "osmode" 167)

(setq oldclayer (getvar "clayer"))

(setq entlist (entget (car (entsel "\nSelect object to set layer as current: "))))
(setvar "clayer" (cdr (assoc 8 entlist)))
(princ "\n\nSelect Objects to Copy to current layer.")
(setq ss (ssget))
(repeat (setq x (sslength ss))
(setq obj (ssname ss (setq x (- x 1))))
(command "copy" obj "" "0,0" "0,0")
(command "chprop" "L" "" "layer" (cdr (assoc 8 entlist)) "")
)
(setvar "osmode" oldsnap)
(setvar "clayer" oldclayer)
(princ)
)
(c:ccl)

Advertisements

Create UCS parallel to current Paper space viewport frame


;;; Create UCS parallel to current Paper space viewport frame.
;;; Need to draw Line/Polyline in Paper Space parallel to Paper space viewport frame
;;; Need to install Richard Stima Xref Tools Extra Plug-in
;;; From Autodesk App Store: https://apps.autodesk.com/MEP/en/Detail/Index?id=6784178835292008697&appLang=en&os=Win32_64
;;; Created by Igal Averbuh 2018 with respect to Richard Stima
(defun c:CS ()
(vl-load-com)

;;; Unlock All viewports

(vlax-for lay
(vla-get-Layouts
(vla-get-ActiveDocument
(vlax-get-acad-object)))
(if (eq :vlax-false (vla-get-ModelType lay))
(vlax-for ent (vla-get-Block lay)
(if (= (vla-get-ObjectName ent) "AcDbViewport")
(vla-put-DisplayLocked ent :vlax-false)))))

(setq sel (entsel "\nSelect object paralel to current vport frame: "))

(command "chspace" sel "" "")

(command "ucs" "ob" "l")

(command "_saveview")

(setvar "tilemode" 1)

(command "_restoreview")

;;; Lock All viewports
(vlax-for lay
(vla-get-Layouts
(vla-get-ActiveDocument
(vlax-get-acad-object)))
(if (eq :vlax-false (vla-get-ModelType lay))
(vlax-for ent (vla-get-Block lay)
(if (= (vla-get-ObjectName ent) "AcDbViewport")
(vla-put-DisplayLocked ent :vlax-true)))))

) ;_end defun
(princ)
(c:cs)

Draw a lightweight Polyline Snaking Curve


;;; SNAKE.LSP
;;; To draw a lightweight Polyline Snaking curve.
;;; Draws a zero-width continuous LWPolyline as a series of approximately 120-degree arc segments,
;;; alternating direction. Intermediate point locations are adjusted for localized path direction on curved
;;; paths, maintaining consistent overall "snake" width. [Non-tangent changes in direction in Polyline
;;; paths, or overly tight curves relative to snake width in some entity types, or non-Centered justification
;;; with Polylines or Splines that intersect (or relative to snake width, get too close to) themselves, may
;;; yield quirky results.]
;;; Divides path length into whole arc chord-length increments to eliminate need for trimming at ends;
;;; forces an even number of segments for closed paths so that result looks continuous across start/end.
;;; Draws on current Layer, unless Deleting pre-Existing path; if so, draws on its Layer, assuming the
;;; intent is to replace it.
;;; Under select-Existing option, asks User to select again if nothing is selected, or if selected object is an
;;; inappropriate entity type.
;;; Accounts for different Coordinate Systems.
;;; Remembers option choices and offers them as defaults for subsequent use.
;;; Options:
;;; 1. create new within the routine, or select pre-Existing, path of any 2D finite type with linearity;
;;; 2. if selected Existing object is on a locked Layer, whether to unlock it and Proceed, or Quit;
;;; 3. PRevious = redraw along prior path (whether retained or deleted) allowing different choices;
;;; 4. Flip = one-step replacement of prior result, if Left- or Right-justified, on other side -- meant for
;;; Existing Line/Pline/Spline (drawing direction not visually apparent), but works on all types;
;;; 5. Retain or Delete base path, whether new or selected Existing;
;;; 6. Snake width between extreme bulge points (midpoints of curves);
;;; 7. Center-line or Left- or Right-side justification (Left & Right are relative to drawing direction
;;; for Line/Pline/Spline; for Arc/Circle/Ellipse, Left draws inside, Right draws outside).
;;;
;;; Kent Cooper, last edited July 2009
;;; Slightly modified by Igal Averbuh 2018 (added x1 x2 x4 wave multiplicator for "snake" width)
(defun snreset ()
(setvar 'osmode osm)
(setvar 'blipmode blips)
(setvar 'plinewid plwid)
(setvar 'plinetype pltyp)
(setvar 'celtype ltyp)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); end defun - snreset
;
(defun locdir (path dist); LOCal DIRection of path at distance along it, accounting for UCS
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
path
(vlax-curve-getParamAtDist path dist)
); end getFirstDeriv
0 1 T ; world to current CS, as displacement
); end trans
); end angle
); end defun - locdir
;
(defun snpt (advpro offpro)
;; This subroutine calculates a SNake polyline definition PoinT, with arguments:
;; advpro = localized amount of ADVance from current Bulge segment's basepoint along path,
;; as a PROportion of segment length
;; offpro = localized amount of OFFset to side from path, as a PROportion of thickness
(polar
(trans
(vlax-curve-getPointAtDist ; advance point along working path
sntpath
(+
(vlax-curve-getDistAtPoint sntpath bbase)
(* advpro blength); proportion of segment length
); end +
); end getPointAtDist
0 1 ; from World coordinates to object's coordinates
); end trans
(+ ; localized angle of offset
(locdir
sntpath
(+
(vlax-curve-getDistAtPoint sntpath bbase)
(* advpro blength)
); end +
); end locdir
(* pi 0.5 side); perpendicular to center-line path [side +/- gives left/right]
); end +
(* offpro *snthk*); proportion of snake thickness
); end polar
); end defun - snpt
;
;;; ******************************** Main Routine: SNAKE ********************************
(defun C:DSL
(/ *error* cmde osm blips plwid pltyp ltyp typetemp pathsel pathdata pathtype
polyclosed unlktemp deltemp thktemp justtemp ucschanged ptno side pldist
plpt sntpath pathlength isCurved vertcheck vertbulge bbase bsegs blength)
;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort"))
(princ (strcat "\nError: " errmsg))
); end if
(if ucschanged (command "_.ucs" "_prev"))
; ^ i.e. don't go back unless routine reached UCS change but didn't change it back
(snreset)
); end defun - *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
osm (getvar 'osmode)
blips (getvar 'blipmode)
plwid (getvar 'plinewid)
pltyp (getvar 'plinetype)
ltyp (getvar 'celtype)
); end setq
(setvar 'osmode 0)
(setvar 'plinewid 0)
(setvar 'plinetype 2)
(setvar 'celtype "CONTINUOUS")
;
(initget
(strcat
"Existing Line Arc Circle Pline ELlipse Spline"
(if *sntype* " PRevious" ""); add PR option only if not first use
(if (member *snjust* '("Left" "Right")) " Flip" ""); add Flip option only if prior was L/R
); end strcat
); end initget
(setq
typetemp
(getkword
(strcat
"\nPath type [Existing, or new Line(single)/Arc/Circle/Pline/ELlipse/Spline"
(if *sntype* "/PRevious" ""); offer PR option if not first use
(if (member *snjust* '("Left" "Right")) "/Flip" ""); add Flip option only if prior was L/R
"] : "
); end strcat
); end getkword & typetemp
*sntype*
(cond
(typetemp); if User typed something other than Enter, use it
(*sntype*); if Enter and there's a prior choice, use that
(T "Pline"); otherwise [Enter on first use], Line default
); end cond & *sntype*
); end setq
;
(if
(and (wcmatch *sntype* "PRevious,Flip") *isLocked*)
(command "_.layer" "_unlock" *pathlay* ""); then - unlock layer without asking [prior Proceed option]
); end if
;
(cond ; select or make path
((= *sntype* "Existing")
(while
(not
(and
(setq
pathsel (car (entsel "\nSelect object to draw a Snake along an Existing path,"))
pathdata (if pathsel (entget pathsel))
pathtype (if pathsel (substr (cdr (assoc 100 (cdr (member (assoc 100 pathdata) pathdata)))) 5))
; ^ = entity type from second (assoc 100) without "AcDb" prefix; using this because (assoc 0)
; value is the same for 2D & 3D Polylines; 2D OK, but not 3D because they can't be offset,
; so only center justification could be offered, and result would be flattened in current CS
); end setq
(wcmatch pathtype "Line,Arc,Circle,Ellipse,Spline,Polyline,2dPolyline")
); end and
); end not
(prompt "\nNothing selected, or it is not a 2D finite path type; try again:")
); end while
); end first condition - Existing
((and (wcmatch *sntype* "PRevious,Flip") (= *sndel* "Delete")) (entdel *snpath*)); bring back prior
((= *sntype* "Line") (setvar 'cmdecho 1) (command "_.line" pause pause "") (setvar 'cmdecho 0))
((not (wcmatch *sntype* "PRevious,Flip")); all other entity types
(setvar 'cmdecho 1)
(command *sntype*)
(while (> (getvar 'cmdactive) 0) (command pause))
(setvar 'cmdecho 0)
); end fourth condition
); end cond
(setvar 'blipmode 0)
;
(setq
*snpath* ; set object as base path [not localized, so it can be brought back if PR/F and D options]
(cond
((= *sntype* "Existing") pathsel); selected object
((wcmatch *sntype* "PRevious,Flip") *snpath*); keep the same
((entlast)); otherwise, newly created path
); end cond & *snpath*
pathdata (entget *snpath*)
pathtype (cdr (assoc 0 pathdata)); can now use this, once past possibility of selecting 3D Polyline
polyclosed ; used in offsetting determinations
(and
(wcmatch pathtype "*POLYLINE"); allow for "heavy" 2D or "lightweight" Polylines
(vlax-curve-isClosed *snpath*)
); end and
*pathlay* (cdr (assoc 8 pathdata))
; ^ not localized, so that under PRevious or Flip options, knows what layer to unlock if needed
*isLocked* ; not localized, so that under PRevious or Flip options, don't need to ask again
(if (and (wcmatch *sntype* "PRevious,Flip") *isLocked*)
T ; keep with PR/F if prior object was on locked layer
(/= (cdr (assoc 70 (tblsearch "layer" *pathlay*))) 0); other types - 0 for Unlocked: nil; 4 for Locked: T
); end if & *isLocked*
); end setq
;
(if *isLocked*
(if (not (wcmatch *sntype* "PRevious,Flip")); then - check for not redoing prior object
(progn ; then - ask whether to unlock
(initget "Proceed Quit")
(setq
unlktemp
(getkword
(strcat
"\nLayer is locked; temporarily unlock and Proceed, or Quit? [P/Q] : "
); end strcat
); end getkword & unlktemp
*snunlk*
(cond
(unlktemp); if User typed something, use it
(*snunlk*); if Enter and there's a prior choice, keep that
(T "Proceed"); otherwise [Enter on first use], Proceed
); end cond & *snunlk*
); end setq
(if (= *snunlk* "Proceed")
(command "_.layer" "_unlock" *pathlay* ""); then
(progn (snreset) (quit)); else
); end if
); end progn & inner else argument
); end inner if & outer then argument
); end outer if - no else argument [no issue if not on locked layer]
;
(if (wcmatch *sntype* "PRevious,Flip") (entdel *sn*))
; ^ if re-using Previous path with new choices, or Flipping to other side, delete previous result
;
(if (/= *sntype* "Flip")
(progn ; then - ask whether to Retain or Delete if not Flipping
(initget "Retain Delete")
(setq
deltemp
(getkword
(strcat
"\nRetain or Delete base path [R/D] : "
); end strcat
); end getkword
*sndel*
(cond
(deltemp); if User typed something, use it
(*sndel*); if Enter and there's a prior choice, keep that
(T "Delete"); otherwise [Enter on first use], Delete
); end cond & *sndel*
); end setq
); end progn
); end if -- no else argument [keep previous option if Flipping]
;
(if (/= *sntype* "Flip")
(progn ; then - ask for thickness if not Flipping
(initget (if *snthk* 6 7) "A B C D"); no Enter on first use, no 0, no negative
(setq
thktemp
(getdist
(strcat
"\nThickness of Snake, or [A=1/B=2/C=4/D=8/E=10/F=12/G=14]"
(if *snthk* (strcat " ") ""); default only if not first use
": "
); end strcat
); end getdist & thktemp
*snthk*
(cond
((= thktemp "A") 1.0)
((= thktemp "B") 2.0)
((= thktemp "C") 4.0)
((= thktemp "D") 8.0)
((= thktemp "E") 10.0)
((= thktemp "F") 12.0)
((= thktemp "G") 14.0)

((numberp thktemp) thktemp); user entered number or picked distance
(T *snthk*); otherwise, user hit Enter - keep value
); end cond & *snthk*
); end setq
); end progn
); end if -- no else argument [keep previous thickness if Flipping]
;
(if (/= *sntype* "Flip")
(progn ; then - ask for justification if not Flipping
(initget "Center Left Right")
(setq
justtemp
(getkword
(strcat
"\nJustification [Center/Left(inside arc,circle,ellipse)/Right(outside)] : "
); end strcat
); end getkword
*snjust*
(cond
(justtemp); if User typed something, use it
(*snjust*); if Enter and there's a prior choice, use that
(T "Center"); otherwise [Enter on first use], Center
); end cond & *snjust*
); end setq
); end progn
(setq *snjust* (if (= *snjust* "Left") "Right" "Left")); else - reverse justification if Flipping
); end if
;
(command "_.ucs" "_new" "_object" *snpath*) ; set UCS to match object
(setq
ucschanged T ; marker for *error* to reset UCS if routine doesn't get to it
ptno 0 ; starting point-number value for intermediate point multiplier
side 1 ; starting directional multiplier for 'side' [left/right of center-path] argument in (snpt)
); end setq
;
(if (= *snjust* "Center")
(command "_.copy" *snpath* "" '(0 0 0) '(0 0 0)); then - copy in place for Center justification
(command ; else - offset by half Snake thickness for Left or Right justification
"_.offset"
(/ *snthk* 2)
*snpath*
(polar
(if polyclosed ; less risk of inside-offsetting Plines closing at acute angles wrongly to outside
(setq ; then - partway in
pldist (vlax-curve-getDistAtParam *snpath* 0.5)
plpt (trans (vlax-curve-getPointAtParam *snpath* 0.5) 0 1)
); end setq
(trans (vlax-curve-getStartPoint *snpath*) 0 1); else - start point
); end if - point argument
(apply
(if (= *snjust* "Left") '+ '-); add for Left, subtract for Right
(list (locdir *snpath* (if polyclosed pldist 0)) (/ pi 2)); partway into closed Pline; else, startpoint
); end apply - angle argument
0.1 ; distance
); end polar
"" ; end offset
); end command - offset & else argument
); end if
;
(setq
sntpath (entlast); save as Temporary [working] PATH
pathlength (vlax-curve-getDistAtParam sntpath (vlax-curve-getEndParam sntpath))
isCurved
; Determine whether path has any curves, calling for more definition points - without them,
; curved paths can result in bulges that are obviously far from tangent crossing path
(cond
((= pathtype "LINE") nil); Lines are never curved
((= pathtype "LWPOLYLINE"); check LWPolylines for arc segments
(if
(vl-remove-if-not ; recognize only non-0 bulge factors
'(lambda (x) (and (= (car x) 42) (/= (cdr x) 0.0)))
pathdata
); end vl-remove-if-not; returns list only if there are arc segments
T ; contains at least one arc segment
nil ; all line segments
); end if
); end LWPolyline condition
((= pathtype "POLYLINE"); check heavy 2D Polylines for arc segments
(setq vertcheck (entnext sntpath))
(while
(and
(not vertbulge)
(= (cdr (assoc 0 (entget vertcheck))) "VERTEX")
); end and
(setq
vertbulge (/= (cdr (assoc 42 (entget vertcheck))) 0.0); T if bulge factor
vertcheck (entnext vertcheck)
); end setq
); end while
vertbulge
); end heavy 2D Polyline condition
(T) ; Arc/Circle/Ellipse/Spline are always curved
); end cond & isCurved
bbase (vlax-curve-getStartPoint sntpath); startpoint is first Bulge BASE point
bsegs ; closed paths need even numbers of Bulge SEGmentS; open can have odd number
(if (vlax-curve-isClosed *snpath*)
(* (fix (+ (/ pathlength *snthk* 3.4641) 0.5)) 2); then - round to nearest *even* number
(fix (+ (/ pathlength *snthk* 1.7321) 0.5)); else - round to nearest *whole* number
); end if & bsegs
blength (/ pathlength bsegs); proportioned Bulge LENGTH
); end setq
;
(if (= *sndel* "Delete") (setvar 'clayer *pathlay*)) ; if Deleting Existing path, draw on same Layer
;
(command
"_.pline"
(snpt 0 0); start point of first bulge
"_arc"
(while (< ptno bsegs)
(setq
bbase (vlax-curve-getPointAtDist sntpath (* blength ptno)); incremented Bulge segment BASE along path
ptno (1+ ptno); increment point number for next time [put here so it's not last function in (while) loop]
); end setq
(command "_second")
(if isCurved
(command ; then - more definition points for curved paths
(snpt 0.1289 0.226); second point of first shorter curve
(snpt 0.3025 0.4397); third point of first shorter curve
"_second"
); end interim command
); end if [no else - continue to next second-point designation]
(command (snpt 0.5 0.5)); 2nd pnt of [middle shorter, or single longer] curve: midpoint of bulge
(if isCurved
(command ; then - more definition points for curved paths
(snpt 0.6975 0.4397); third point of middle curve
"_second"
(snpt 0.8711 0.226); second point of third curve
); end interim command
); end if [no else - continue to next thirdd-point designation]
(command
(if (= ptno bsegs); third point of last curve in overall Bulge
(trans (vlax-curve-getEndPoint sntpath) 0 1)
(snpt 1.0 0); else - intermediate
); end if
); end command
(if (/= ptno bsegs) (setq side (- side))); for next bulge on other side of path
); end while
); end command - pline
;
(command "_.ucs" "_prev")
(setq
ucschanged nil ; eliminate UCS reset in *error* since routine did it already
*sn* (entlast); save result in case of recall of routine with PRevious or Flip option
); end setq
(entdel sntpath); remove temporary working path
(if (= *sndel* "Delete") (entdel *snpath*)); remove base path under Delete option
;
(if (and (wcmatch *sntype* "Existing,PRevious,Flip") (= *sndel* "Delete")) (command "_.layerp"))
; ^ reset Layer if appropriate
(if *isLocked* (command "_.layer" "_lock" *pathlay* "")); re-lock layer if appropriate
(snreset)
(princ)
); end defun - SNAKE
(prompt "Type DSL to make polyline-form snaking curve.")
(c:DSL)

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)

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)