Copy Nested (xref) object in the exact same location on main drawing in a one click


;;; Copy Nested (Xref) object in the exact same location on main drawing in a one click
;;; Modified by Igal Averbuh 2018 (added loop option and set red colour of object transfered to main drawing)
;;; Inspired by patric_35 routine: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-objects-from-xref/td-p/2552308

(defun c:nc(/ blo cod ent nom sel)

(and (setq sel (nentselp))
(= (type (setq blo (last (last sel)))) 'ENAME)
(/= (logand (cdr (assoc 70 (tblsearch "block" (setq nom (cdr (assoc 2 (entget blo))))))) 124) 0)
(setq ent (entget (car sel)))
(progn
(foreach cod '(-1 5 330)
(setq ent (vl-remove (assoc cod ent) ent))
)
(foreach cod '(6 8)
(and (assoc cod ent)
(eq (substr (cdr (assoc cod ent)) 1 (strlen nom)) nom)
(setq ent (subst (cons cod (substr (cdr (assoc cod ent)) (+ (strlen nom) 2))) (assoc cod ent) ent))
)
)
(entmake ent)
(setq obj (vlax-ename->vla-object (entlast)))
(vla-transformby obj (vlax-tmatrix (caddr sel)))
(setq lst (cons (list obj (vla-get-color obj)) lst))
(vla-put-color obj 1)
(vla-update obj)
)
)
(princ)
(c:nc)
)
;(c:nc)

Advertisements

Changes selected object layer to a true color (RGB) with dialog box


;;Changes selected object layer to a true color
;;of chose from a dialog
;; Created by: Jason Rhymes
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/layer-color-to-true-color-color-books-by-picking-an-object-from/td-p/2431036
box
(defun c:slt (/ ent ent_data rgb str objlay)

(setq ent
(entsel)
)

(setq ent_data
(entget
(car ent)

)
)
(setq rgb

(TrueColor-split
(cdr (assoc
420

(acad_truecolordlg
'(420 .
16711680)

)
)
)
)
)

(setq str
(strcat
(rtos (car rgb) 2
0)
","
(rtos (cadr rgb) 2
0)
","
(rtos (caddr rgb) 2
0)
)
)
(setq objlay

(cdr
(assoc 8 ent_data)
)
)

(command "layer" "Color" "T" str objlay "")
)
(defun TrueColor-split (c
/)
(list (lsh (fix c) -16)
(lsh (lsh (fix c) 16)
-24)
(lsh (lsh (fix c) 24) -24)

)
)
(c:slt)

Unable to delete/move/select viewport

John.vellek providing a summary of the solutions of this issue:
Saved from: https://forums.autodesk.com/t5/autocad-forum/unable-to-delete-move-select-viewport/td-p/4364254

  • Verify all layers are on and thawed including the VP layer settings.

 

 

  • If the Viewport is on the defpoints layer, try renaming defpoints.

 

  • Double-click inside the viewport to make it active.
    Maximize the viewport by clicking the + sign in the top left corner.
    Change back to paper space and you can now see and select the viewport.

Capture.PNG

 

  • Draw a rectangle over the viewport
    Qselect the viewport
  • Capture1.PNG
    use VPCLIP (viewport is still selected)
    Select the rectangle.

John Vellek
Technical Support Specialist

* One can create a Viewport with an Object, then erase that Object.

The Viewport will remain with no way to manipulate the Viewport.

* Draw a rectangle over the top of the viewport in paperspace.

Use QUICKSELECT to select only the viewport.

Start the Viewport Clip command (VPCLIP).

It will already have the viewport selected and will prompt you to select the object to clip with.

Select the rectangle.

And You should have a workable viewport.

*  If you have issues with selecting a viewport, here is the magic fix: (if it is on the Defpoints layer) change the word defpoints to “Defpoint”  no “s”. Make a new viewport under the correct defpoints, delete the old one and purge to get rid of the corrupt layer.

* A faster fix that doesn’t involve changing the Defpoints layer: In paperspace, use ctrl+A to select everything and use shift+select to deselect everything except the viewport.  The viewport is now the only thing selected and can be moved off of the Defpoints layer

  • If you have them on Defpoints, and layer 0 is frozen or off, you can’t select anything on the
    Defpoints layer.

 

Linear Interpolation elevation value between two defined by user points (elevation given by selecting text or attribute values on screen)


;;; Linear Interpolation elevation value between two defined by user points (elevation given by selecting text or attribute values on screen)
;;; Created by Igal Averbuh 2018
;;; Inspired by codes seved from: http://www.cadtutor.net/forum/showthread.php?44496-Interpolation-Lisp-Needed
;;; with great respect to their authors

(defun c:INT (/ p1 p2 p3 p4 el1 el2 el3 d12 vecs tepPt deltaE deltaE3)
(alert "\nNeed to disable WinHEB in order to work with this program\n")
(setvar "osmode" 167)
(defun LayerPurgePrevention (dictName layerNameList / layerEnameList)
(dictremove (namedobjdict) dictName)
(if
(setq layerEnameList
(vl-remove
nil
(mapcar
'(lambda (layerName) (tblobjname "layer" layerName))
layerNameList
)
)
)
(dictadd
(namedobjdict)
dictName
(entmakex
(vl-list*
'(0 . "XRECORD")
'(100 . "AcDbXrecord")
(mapcar
'(lambda (layerEname) (cons 340 layerEname))
layerEnameList
)
)
)
)
)
)

(setvar "cmdecho" 0)
(command "-layer" "m" "000-Interpolate Text Labels" "")

(LayerPurgePrevention "OnsBedrijfLayerPurgePrevention" '("000-Interpolate Text Labels"))

(command "-style" "Igal" "Arial.ttf" "0" "" "" "" "")

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Text Height : ")))
((getvar 'textsize))
)
)

(and (setq p1 (getpoint "\nPick First point: "))
(setq el1 (getreal "\nEnter elevation."))
(setq p2 (getpoint p1 "\nPick Second point: "))
(setq el2 (getreal "\nEnter elevation."))
(setq deltaE (- el2 el1)
d12 (distance p1 p2))
(while (setq p3 (getpoint "\nPick point for elevation: "))
(redraw)
(grvecs (list 1 p1 p3 p3 p2))
(setq tmpPt (polar p3 (+ (/ pi 2) (angle p1 p2)) 10.0))
(setq p4 (inters p1 p2 p3 tmpPt nil))
(setq deltaE3 (*(/ (distance p1 p4) (distance p1 p2))deltaE))
(if (> (distance p2 p4) d12)
(setq el3 (- el1 deltaE3))
(setq el3 (+ el1 deltaE3))
)
(command "text" p3 "" "" (rtos el3))
(princ (strcat "Elevation at point is: " (rtos el3)))
; (redraw)
)
)
)
(c:int)

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)

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)