Set the Default Application to open DWG Files

Set the Default Application to open DWG Files

Saved from: https://thecadgeek.com/blog/opening-drawings-with-windows-explorer/

While it’s certainly possible the SDI variable was changed from its default value of 0, the more common cause to drawings opening in a new session of AutoCAD is related to the application associated with DWG files on your computer. Although it might seem logical to set AutoCAD as the default program for DWG files, doing so will cause every drawing to open in a new session of AutoCAD. Instead, the default program associated with DWG files should be the “AutoCAD DWG Launcher”.

To set the “AutoCAD DWG Launcher” as the default program for DWG files:

  1. Locate a DWG file in Windows Explorer.
  2. Right-click on the DWG file and select Properties.
  3. On the General tab of the Properties Dialog, select the “Change” button next to the “Opens With” property.
    Windows File Properties Dialog
    Windows File Properties Dialog
  4. Locate “AutoCADDWG Launcher” within the “Opens With” dialog, and click OK.
    Windows Open With Dialog
    Windows Open With Dialog

Double-clicking DWG files from Windows Explorer should now open drawings in a single session of AutoCAD.

Draw “Heat Grid” (Lee Mac)


;;; Saved from: https://www.cadtutor.net/forum/topic/43738-a-challenge-how-to-draw-this-floor-heating/
;;----------------------------=={ Heat Grid }==-------------------------;;
;; ;;
;; Prompts the user to select a rectangular closed LWPolyline and ;;
;; specify a grid wire spacing, and proceeds to construct a maximised ;;
;; filleted spiral centered within the selected LWPolyline based on ;;
;; the given wire spacing. ;;
;; ;;
;; The program will perform successfully with rectangular LWPolylines ;;
;; at any rotation or orientation, and with all UCS & Views. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;

(defun c:hg ( / 2pi a1 a2 bl d2 di en h1 h2 ix l1 l2 l3 mt no p1 p2 pi2 rm tv v1 vl w1 w2 zv )
(setq pi2 (/ pi 2.0)
2pi (+ pi pi)
)
(while
(progn
(setvar 'errno 0)
(setq en (car (entsel "\nSelect Rectangular Closed LWPolyline: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type en))
(if (null (LM:rectangle-p en))
(princ "\nObject must be a Rectangular Closed LWPolyline.")
)
)
)
)
)
(if (= 'ename (type en))
(progn
(setq vl
(apply 'append
(mapcar
(function
(lambda ( dx )
(if (= 10 (car dx))
(list (trans (cdr dx) en 1))
)
)
)
(entget en)
)
)
)
(setq a1 (angle (car vl) (cadr vl))
w1 (distance (car vl) (cadr vl))
h1 (distance (cadr vl) (caddr vl))
)
(if (< h1 w1)
(setq tv w1
w1 h1
h1 tv
a1 (+ a1 pi2)
)
)
(setq w2 w1
h2 h1
)
(while
(and
(progn
(initget 6)
(setq di
(getdist
(strcat "\nSpecify Wire Spacing"
(if *spacing* (strcat " : ") ": ")
)
)
)
(if (null di)
(setq di *spacing*)
(setq *spacing* di)
)
)
(progn
(setq no (fix (/ w2 di))
rm (rem w2 di)
)
(if (equal 0.0 rm 0.1)
(setq no (1- no)
rm (+ rm di)
)
)
(if (zerop (rem no 2))
(setq no (1- no)
rm (+ rm di)
)
)
(< no 2)
)
)
(princ "\nWire Spacing too large.")
)
(if (= 'real (type di))
(progn
(setq w2 (- w2 rm)
h2 (- h2 rm)
p1 (list (/ rm 2.0) (/ rm 2.0) 0.0)
l1 (list p1)
a2 pi2
ix 0
)
(repeat no
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l1 (cons p1 l1)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
(setq l1 (reverse l1)
w2 (- w1 rm di di)
h2 (- h1 rm di)
p1 (list (+ (/ rm 2.0) di) (/ rm 2.0) 0.0)
l2 (list p1)
a2 pi2
ix 0
)
(repeat (- no 2)
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l2 (cons p1 l2)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (= ix 2)
(setq h2 (- h2 di))
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
)
(setq
v1
(mapcar '- (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) (car vl) (caddr vl))
(setq p2
(apply 'mapcar
(cons (function (lambda ( a b ) (/ (+ a b) 2.0)))
(mapcar
(function
(lambda ( x ) (apply 'mapcar (cons x l1)))
)
'(min max)
)
)
)
)
)
d2 (/ di 2.0)
bl (/ (sin (/ pi -8.0)) (cos (/ pi 8.0)))
l1
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list b)
)
( (null c)
(list (polar b (angle b a) d2))
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l1)
l1
(append (cdr l1) '(nil))
)
)
bl (- bl)
l2
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list (polar b (angle b c) d2))
)
( (null c)
(list b)
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l2)
l2
(append (cdr l2) '(nil))
)
)
zv (trans '(0.0 0.0 1.0) 1 0 t)
mt (list (list (cos a1) (- (sin a1))) (list (sin a1) (cos a1)))
v1 (mapcar '+ v1 (mapcar '- p2 (mxv mt p2)))
l3
(mapcar
(function
(lambda ( x )
(if (listp x)
(cons 10 (trans (mapcar '+ (mxv mt x) v1) 1 zv))
(cons 42 x)
)
)
)
(append l1 (list -1.0 (polar (last l1) (+ a2 pi) di) (polar (car l2) a2 di) 1.0) l2)
)
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 090 (length (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) l3)))
'(070 . 0)
(cons 210 zv)
)
l3
)
)
)
)
)
)
(princ)
)

;; Rectangle-p - Lee Mac
;; Returns T if the supplied entity is a rectangular closed LWPolyline

(defun LM:rectangle-p ( e / a b c d )
(and
(= "LWPOLYLINE" (cdr (assoc 0 (setq e (entget e)))))
(= 4 (cdr (assoc 90 e)))
(= 1 (logand 1 (cdr (assoc 70 e))))
(LM:nobulge-p e)
(mapcar 'set '(a b c d)
(apply 'append
(mapcar '(lambda ( x ) (if (= 10 (car x)) (list (cdr x)))) e)
)
)
(LM:perp-p (mapcar '- a b) (mapcar '- a d))
(LM:perp-p (mapcar '- a b) (mapcar '- b c))
(LM:perp-p (mapcar '- a d) (mapcar '- c d))
)
)

;; Perpendicular-p - Lee Mac
;; Returns T if the supplied vectors are perpendicular

(defun LM:perp-p ( u v )
(equal 0.0 (apply '+ (mapcar '* u v)) 1e-8)
)

;; No Bulge-p - Lee Mac
;; Returns T if the supplied LWPolyline DXF list has zero bulge

(defun LM:nobulge-p ( e / p )
(or (not (setq p (assoc 42 e)))
(and (equal 0.0 (cdr p) 1e-8)
(LM:nobulge-p (cdr (member p e)))
)
)
)

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

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

(vl-load-com)
(princ
(strcat
"\n:: HeatGrid.lsp | Version 1.0 | © Lee Mac "
(menucmd "m=$(edtime,$(getvar,DATE),YYYY)")
" http://www.lee-mac.com ::"
"\n:: Type \"hg\" to Invoke ::"
)
)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:hg)

PROGRAM FOR SPRINKLER DISTRIBUTION


;;; Sprinkler Distribution Program
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/sprinkler-spaces/td-p/9335919
;;; Need to insert PENDANT sprinkler block named "spr" into drawing
;;; or UPRIGHT sprinkler block named "spu"

(setvar 'cmdecho 0)
(command "_.layer" "_make" "M-FIRE-SYMB-P" "_color" "1" "" "")
(setvar 'cmdecho 1)
(vl-load-com)

(defun SS ; = Sprinkler Spacing
(blkname / *error* ssia doc svnames svvals v1 rectss n ucschanged v3)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if ucschanged (command-s "_.ucs" "_previous"))
; [change to (command ... if Acad version predates (command-s) function]
(mapcar 'setvar svnames svvals); reset System Variables
(vla-endundomark doc)
(princ)
); defun - *error*

(defun ssia ; = SS Insert & Array
(/ delta LL nLong longEdge spcMax spcLong spcShortTemp
nShort shortEdge spcShort longX nX nY spcX spcY)
(setq
delta (reverse (cdr (reverse (mapcar 'abs (mapcar '- v3 v1)))))
; XY [only] differences list
LL (mapcar 'min v1 v3)
; Lower Left regardless of pick order or Pline start or direction
nLong
(+
(fix (/ (setq longEdge (apply 'max delta)) (setq spcMax (cadr (assoc haz hazlist)))))
; rounded-down longer dimension divided by base max. spacing
(if (= (rem longEdge spcMax) 0) 0 1); round up if any remainder
); + & nLong
spcLong (/ longEdge nLong); spacing in long direction
spcShortTemp (/ (caddr (assoc haz hazlist)) spcLong)
; max. area div. by long-direction spacing
nShort
(+
(fix (/ (setq shortEdge (apply 'min delta)) spcShortTemp))
; rounded-down shorter dimension divided by max. spacing
(if (= (rem shortEdge spcShortTemp) 0) 0 1); round up if any remainder
); + & nShort
); setq
(while (> (setq spcShort (/ shortEdge nShort)) spcMax)
; spacing in short direction, compared to maximum spacing
(setq nShort (1+ nShort))
); while
(setq
longX (apply '> delta); is it longer in X dimension?
nX (if longX nLong nShort); number in X direction
spcX (if longX spcLong spcShort); spacing in X direction
nY (if longX nShort nLong)
spcY (if longX spcShort spcLong)
); setq
(command
"_.insert" blkname "_none" (mapcar '+ LL (list (/ spcX 2) (/ spcY 2))) "" "" ""
"_.array" "_last" "" "_r" nY nX
); command [leaves in Array command at prompt for spacing(s)]
(cond
((= nX 1) (command spcY))
((= nY 1) (command spcX))
(T (command spcY spcX))
); cond
); defun -- ssia

(vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(setq ; System Variable saving/resetting without separate variables for each:
svnames '(cmdecho ucsfollow osmode blipmode)
svvals (mapcar 'getvar svnames)
); setq
(mapcar 'setvar svnames '(0 0)); turn off command echoing, UCS follow
(initget 1 "Light Ordinary Extra"); 1 = no Enter
(setq
hazlist
'(
("Combustible" 460 210000) ("Non-Combustible" 460 180000); Light subtypes
("Ordinary" 460 120000) ("Extra" 370 90000)
)
haz (getkword "\nSpecify Space Hazard Type [Light/Ordinary/Extra]: ")
); setq
(if (= haz "Light")
(progn
(initget 1 "Combustible Non-Combustible")
(setq haz (getkword "\nLight Hazard subtype [Combustible/Non-combustible]: "))
); progn
); if
(initget "Select"); allows S as input to (getpoint) function, instead of point pick
(setq v1 (getpoint "\nFirst Corner of rectangular area for Sprinklers, or [Select]: "))
; [if in non-World UCS, returns in current UCS coordinates, not in WCS]
(if (= v1 "Select"); chose that option
(progn ; then
(prompt "\nTo distribute Sprinklers in rectangular Polylines,")
(if (setq rectss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&") (70 . 1))))
; multiple selection -- only 4-vertex closed [does not check for rectangularity]
(progn ; then
(mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
(repeat (setq n (sslength rectss)); step through selection
(setq rect (ssname rectss (setq n (1- n))))
(command "_.ucs" "_object" rect)
(setq
ucschanged T ; marker for resetting in *error*
v1 (trans (vlax-curve-getPointAtParam rect 0) 0 1); starting vertex
v3 (trans (vlax-curve-getPointAtParam rect 2) 0 1); third vertex [opposite corner]
); setq
(ssia); run the subroutine to Insert and Array
(command "_.ucs" "_previous")
(setq ucschanged nil); [turn off marker]
); repeat
); progn
(prompt "\nNo closed 4-vertex Polyline(s) selected."); else
); if
); progn
(progn ; else [picked a point]
(setq v3 (getcorner v1 "\nOpposite Corner: "))
(mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
(ssia); run the subroutine to Insert & Array
); progn
); if
(mapcar 'setvar svnames svvals); reset System Variables
(vla-endundomark doc)
(princ)
); defun -- SS

(defun C:SSP ()
(SS "SPR")
); defun

(defun C:SSU ()
(SS "SPU")
); defun

(prompt "\n THIS PROGRAM FOR SPRINKLER DISTRIBUTION ")
(prompt "\n START command by : SSP:PENDANT SSU:UPRIGHT ")
(prompt "\n\n CREATED by :\n ********* M.SAIED. ********* ")
(prompt "\n MODIFIED by :\n ********* Saber Elkassas & Kent Cooper. ********* ")
(princ)

How to remove Frames around blocks

If your drawings are showing frames around blocks and clipped xrefs
and you need to remove it try

FRAME = 0

AutoCAD Help says:

Turns the display of frames on and off for all external references, images, and DWF, DWFx, PDF, and DGN underlays. The FRAME setting overrides the individual IMAGEFRAME, DWFFRAME, PDFFRAME, DGNFRAME, and XCLIPFRAME settings.
0 The frame is not visible and it is not plotted

1 Displays the frame and allows it to be plotted

2 Displays the frame but keeps it from being plotted

3 The setting varies for all attached images, underlays, and xrefs

or another solution

The possible reason: It’s come from any regular block or dynamic block after they got xclipped. In 2000 – 2010 versions the xclip frame is invisible and uneditable but from 2011 you can set it visibility via the XCLIPFRAME variable and grip edit / invert it.

XCLIPFRAME = 0 to turn off.

That’s a clip boundary. The benefit of leaving it on is that you can edit the clip from the boundary grips, and invert clipping side (likes making a hole inside your block, in your case, the boundary is larger than the block extent so when you invert it, you see nothing).

or

FRAMESELECTION (System Variable)

Set FRAMESELECTION to 0

Controls whether the hidden frame of an image, underlay, clipped xref, or wipeout can be selected.

Type: Integer
Saved in: Registry
Initial value: 1

Value

Description

0
Hidden frames cannot be selected
1
Hidden frames can be selected.

Delete All Attributes in selected blocks


;; ATTDEL.LSP for d2cad by John F. Uhden 01-17-17
;; Just select inserts. Those without attributes will be filtered out.
;; Actually, you can pick anything, but only inserts with attributes
;; will be selected.
;; Attributes on locked layers will report errors, but
;; the program will continue.
;; It does not change any block definition, but you could copy the
;; emasculated block insertions.
;;
(defun C:AT ( / *error* err vars ss i obj atts m n)
(vl-load-com)
(defun *error* (err)
(mapcar '(lambda (x)(setvar (car x)(cdr x))) vars)
(vla-endundomark *doc*)
(cond
((not err))
((wcmatch (strcase err) "*CANCEL*,*QUIT*"))
(1 (princ (strcat "\nERROR: " err)))
)
(princ)
)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(or *doc* (setq *doc* (vla-get-ActiveDocument *acad*)))
(vla-endundomark *doc*)
(vla-startundomark *doc*)
(setq vars (mapcar '(lambda (x)(cons x (getvar x))) '("cmdecho")))
(mapcar '(lambda (x)(setvar (car x) 0)) vars)
(command "_.expert" (getvar "expert")) ;; dummy command
(and
(setq ss (ssget '((0 . "INSERT")(66 . 1))))
(setq i (sslength ss) n 0 m 0)
(while (> i 0)
(setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
(setq atts (vla-getattributes obj))
(setq atts (vlax-variant-value atts))
(foreach att (vlax-safearray->list atts)
(setq m (1+ m))
(if (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vla-delete (list att))))
(princ (strcat "\nERROR: " (vl-catch-all-error-message err)))
(setq n (1+ n))
)
)
)
)
(princ (strcat "\nDeleted " (itoa n) "/" (itoa m) " attributes."))
(*error* nil)
)

Renumber all PS layouts, with an optional prefix and/or suffix.


;;------------------------=={ Renumber Layouts }==----------------------;;
;; ;;
;; This program enables the user to automatically sequentially ;;
;; renumber all Paperspace layouts, with an optional prefix and/or ;;
;; suffix. ;;
;; ;;
;; The layouts are renumbered in the order in which they appear in ;;
;; the active drawing, with a configurable parameter defining the ;;
;; number of digits constituting the numerical portion of the layout ;;
;; name. ;;
;; ;;
;; The user may optionally predefine a fixed prefix and/or suffix ;;
;; within the 'Program Parameters' section of the source code below, ;;
;; or, if such parameters are set to nil, the program will prompt the ;;
;; user to specify the prefix and suffix upon invoking the command. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2020 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2020-01-26 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;

(defun c:rl ( / *error* int lst lyn ord pad pre sed suf )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(setq

;;----------------------------------------------------------------------;;
;; Program Parameters ;;
;;----------------------------------------------------------------------;;

;; Optional Predefined Layout Prefix
;; Set to nil to prompt the user, or "" for no prefix.
pre nil

;; Optional Predefined Layout Suffix
;; Set to nil to prompt the user, or "" for no suffix.
suf nil

;; Number of Numerical Digits
;; e.g. 1 = "1", 2 = "01", 3 = "001"
pad 2

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

)

;; Obtain a valid (optional) prefix & suffix
(or (= 'str (type pre)) (setq pre (LM:rl:validstring "\nSpecify prefix : ")))
(or (= 'str (type suf)) (setq suf (LM:rl:validstring "\nSpecify suffix : ")))
(or (and (= 'int (type pad)) (<= 0 pad)) (setq pad 0))

;; Obtain list of layout objects, current names, and sort index
(vlax-for lyt (vla-get-layouts (LM:acdoc))
(if (= :vlax-false (vla-get-modeltype lyt))
(setq lst (cons lyt lst)
lyn (cons (strcase (vla-get-name lyt)) lyn)
ord (cons (vla-get-taborder lyt) ord)
)
)
)

;; Construct a unique seed for temporary renaming
(setq lyn (cons (strcase pre) lyn)
sed "%"
)
(while (vl-some '(lambda ( x ) (wcmatch x (strcat "*" sed "*"))) lyn)
(setq sed (strcat sed "%"))
)

;; Temporarily rename layouts to ensure no duplicate keys when renumbering
(LM:startundo (LM:acdoc))
(setq int 0)
(foreach lyt lst
(vla-put-name lyt (strcat sed (itoa (setq int (1+ int)))))
)

;; Rename layouts in tab order, with prefix & suffix
(setq int 0)
(foreach idx (vl-sort-i ord '<)
(vla-put-name
(nth idx lst)
(strcat pre (LM:rl:padzeros (itoa (setq int (1+ int))) pad) suf)
)
)
(LM:endundo (LM:acdoc))
(princ)
)

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

(defun LM:rl:validstring ( msg / rtn )
(while
(not
(or
(= "" (setq rtn (getstring t msg)))
(snvalid (vl-string-trim " " rtn))
)
)
(princ (strcat "\nThe layout name cannot contain the characters \\/?\":;*|,=`"))
)
rtn
)

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

(defun LM:rl:padzeros ( str len )
(if (< (strlen str) len) (LM:rl:padzeros (strcat "0" str) len) str)
)

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

;; 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)
(princ
(strcat
"\n:: RenumberLayouts.lsp | Version 1.0 | \\U+00A9 Lee Mac "
((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2020")
" http://www.lee-mac.com ::"
"\n:: Type \"RL\" to Invoke ::"
)
)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

Imports a coordinate text file as AutoCAD points


; ASCPOINT.LSP Copyright 1990-97 Tony Tanzillo All Rights Reserved.
;
;; Author: Tony Tanzillo,
;; Design Automation Consulting
;; http://ourworld.compuserve.com/homepages/tonyt
;; tony.tanzillo@worldnet.att.net
;; Block extension by V.Michl, CAD Studio, 2012/2013:
;; http://www.cadstudio.cz http://www.cadforum.cz
;;
;; Permission to use, copy, modify, and distribute this software
;; for any purpose and without fee is hereby granted, provided
;; that the above copyright notice appears in all copies and
;; that both that copyright notice and the limited warranty and
;; restricted rights notice below appear in all copies and all
;; supporting documentation, and that there is no charge or fee
;; charged in return for distribution or duplication.
;;
;; This SOFTWARE and documentation are provided with RESTRICTED
;; RIGHTS.
;;
;; Use, duplication, or disclosure by the Government is subject
;; to restrictions as set forth in subparagraph (c)(1)(ii) of
;; the Rights in Technical Data and Computer Software clause at
;; DFARS 252.227-7013 or subparagraphs (c)(1) and (2) of the
;; Commercial Computer Software Restricted Rights at 48 CFR
;; 52.227-19, as applicable. The manufacturer of this SOFTWARE
;; is Tony Tanzillo, Design Automation Consulting.
;;
;; NO WARRANTY
;;
;; ANY USE OF THIS SOFTWARE IS AT YOUR OWN RISK. THE SOFTWARE
;; IS PROVIDED FOR USE "AS IS" AND WITHOUT WARRANTY OF ANY KIND.
;; TO THE MAXIMUM EXTENT PERMITTED BY APPLICABLE LAW, THE AUTHOR
;; DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING, BUT
;; NOT LIMITED TO, IMPLIED WARRANTIES OF MERCHANTABILITY AND
;; FITNESS FOR A PARTICULAR PURPOSE, WITH REGARD TO THE SOFTWARE.
;;
;; NO LIABILITY FOR CONSEQUENTIAL DAMAGES. TO THE MAXIMUM
;; EXTENT PERMITTED BY APPLICABLE LAW, IN NO EVENT SHALL
;; THE AUTHOR OR ITS SUPPLIERS BE LIABLE FOR ANY SPECIAL,
;; INCIDENTAL, INDIRECT, OR CONSEQUENTIAL DAMAGES WHATSOEVER
;; (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF
;; BUSINESS PROFITS, BUSINESS INTERRUPTION, LOSS OF BUSINESS
;; INFORMATION, OR ANY OTHER PECUNIARY LOSS) ARISING OUT OF
;; THE USE OF OR INABILITY TO USE THE SOFTWARE PRODUCT, EVEN
;; IF THE AUTHOR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGES. BECAUSE SOME JURISDICTIONS DO NOT ALLOW EXCLUSION
;; OR LIMITATION OF LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL
;; DAMAGES, THE ABOVE LIMITATION MAY NOT APPLY TO YOU.
;;
;
; ASCPOINT.LSP is a utility for use with AutoCAD Release 10 or later,
; which reads coordinate data from ASCII files in CDF or SDF format,
; and generates AutoCAD geometry from the imported coordinates.
;
; The ASCPOINT command will read coordinate data from an ASCII file,
; and generate either a continuous string of LINES, a POLYLINE, a
; 3DPOLYline, multiple copies of a selected group of objects, or
; AutoCAD POINT entities.
;
; Format:
;
; Command: ASCPOINT
; File to read: MYFILE.TXT <- ASCII input file
; Comma/Space delimited : Comma <- data format
; Generate Copies/Lines/Nodes/3Dpoly/: Nodes <- entity to create
; Reading coordinate data...
;
; If you selected "Copies", then ASCPOINT will prompt you to select the
; objects that are to be copied. The basepoint for all copies is the
; current UCS origin (0,0,0). One copy of the selected objects will be
; created for each incoming coordinate, using each coordinate as the
; displacement relative to the origin.
;
; A comma-delimited (CDF) ascii file contains one coordinate per line,
; with each component seperated by a comma, like this:
;
; 2.333,4.23,8.0
; -4.33,0.0,6.3
; 0.322,5.32,0.0,attribute1,attribute2
; etc....
;
; There should be no spaces or blank lines in a CDF coordinate data file.
;
; A space-delimited (SDF) ascii file contains one coordinate per line,
; with each component seperated by one or more spaces, like this:
;
; 2.333 4.23 8.0
; -4.33 0.0 6.3
; 0.322 5.32 0.0 attribute1 attribute2
; ...
;
; Coordinate data can be 2D or 3D.
;
; Note that all numeric values must have at least one digit to the left
; and the right of the decimal point (values less than one must have a
; leading 0), and a leading minus sign indicates negative values. This
; applys to both CDF and SDF formats.
;
; ASCPOINT can generate a continuous chain of LINE entities from your
; coordinate data, where each pair of adjacent lines share a coordinate
; from the file.
;
; ASCPOINT can also generate a polyline or 3DPOLYline from the coordinate
; data, where each point in the file becomes a vertice of the polyline.
; If the input file contains 3D coordinates, and you specify a polyline,
; then the Z component is ignored and the default of 0.0 is used.
;
; ASCPOINT will also COPY a selected group of objects, creating one copy
; for each incoming coordinate, and using the coordinate as the absolute
; copy displacement from the CURRENT UCS origin (0,0,0).
;
; Finally, ASCPOINT will generate AutoCAD POINT entities from the data in
; the file. Specify the point size and type prior to invoking ASCPOINT.
;
; Writing POINT coordinates to file:
;
; The WPOINT command also included in this file, will export the
; coordinates of selected POINT entities to a comma-delimited CSV
; file that can be read into Excel, and imported using ASCPOINT.
;
; Good luck,
;
; Tony Tanzillo

(defun C:ASCPOINT ( / f bm hi format input line plist ss makepoint blname pt i oldatt)
(cond ( (not (setq f (getfiled "Import ASCII Coordinate Data"
"" "" 0))))
( (not (setq f (open f "r")))
(princ "\nCan't open file for input."))
(t (initget "Space Comma")
(setq format
(cond ((getkword "\n[Comma/Space] delimited : "))
(t "Comma")))
(initget "Copies Inserts Lines Nodes 3Dpoly Pline")
(setq input
(cdr (assoc
(cond
( (getkword
"\nGenerate [Copies/Inserts/Lines/Nodes/3Dpoly/Pline] : "))
(t "Pline"))
'(("Lines" . "._LINE")
("Copies" . "._COPY")
("Inserts" . "._-INSERT")
("Nodes" . "._POINT")
("3Dpoly" . "._3DPOLY")
("Pline" . "._PLINE"))))
)
(setq read-point
(if (eq format "Comma") cdf sdf)
)
(setq makepoint
(if (eq input "._PLINE") 2dpoint (if (eq input "._-INSERT") anypoint 3Dpoint)) ; VM
)
(setvar "cmdecho" 0)
(command "._UNDO" "_Begin")
(setq bm (getvar "blipmode"))
(setq hi (getvar "highlight"))
(setvar "blipmode" 0)
(princ "\nReading coordinate data...")
(while (setq line (read-line f))
(cond
( (and (setq line (strtrim line))
(/= line "")
; (setq line (makepoint (read-point line)))) ; changed VM 1/2013
(setq line (makepoint (sparser line (if (eq format "Comma") "," " ")))))
(setq plist (cons line plist)))))
(close f)
(setq plist (reverse plist))
(cond ( (eq input "._POINT")
(setvar "highlight" 0)
(command "._POINT" "0,0,0"
"._COPY" (setq ss (entlast)) "" "_m" "0,0,0")
(apply 'command plist)
(command)
(entdel ss))

( (eq input "._COPY")
(princ "\nSelect objects to copy,")
(while (not (setq ss (ssget)))
(princ "\nNo objects selected,")
(princ " select objects to copy,"))
(setvar "HIGHLIGHT" 0)
(command "._COPY" ss "" "_m" "0,0,0")
(apply 'command plist)
(command))

( (eq input "._-INSERT")
(setq ss (entsel "\nSelect the block to insert (may have attributes) : "))
(if ss (progn
(setq blname (cdr (assoc 2 (entget (car ss)))))
(princ blname)
);else
(setq blname (getstring "\nBlock name: "))
)
(if blname (progn
(setq oldatt (getvar "ATTDIA"))(setvar "ATTDIA" 0)
(foreach pt plist
;(PRINT PT)(setvar "CMDECHO" 1)
; (command "._-INSERT" blname (3dpoint pt) 1 0) ; or older INSERTs: ) 1 1 0)
(command "._-INSERT" blname "_Sca" 1 (3dpoint pt) 0) ; scale, point, rot
; (setq i 3)(while (> (getvar "CMDACTIVE") 0)(command (toSym (nth i pt)))(setq i (1+ i))) ; attributes changed VM 1/2013
(setq i 3)(while (> (getvar "CMDACTIVE") 0)(if (nth i pt)(command (nth i pt))(command ""))(setq i (1+ i))) ; any No. of attributes 8/2013
)
(setvar "ATTDIA" oldatt)
));if
)

(t (command input)
(apply 'command plist)
(command)))

(command "._UNDO" "_en")
(setvar "highlight" hi)
(setvar "blipmode" bm)))
(princ)
)

(defun sparser (str delim / ptr lst) ; string parser - VM 1/2013
(while (setq ptr (vl-string-search delim str))
(setq lst (cons (substr str 1 ptr) lst))
(setq str (substr str (+ ptr 2)))
)
(reverse (cons str lst))
)

(defun cdf (l / s)
; (command "._LASTPOINT" l)
; (getvar "lastpoint")
; VM:
(setq s (vl-string-translate "," " " l)); maybe also ";"
(read (strcat "(" s ")"))
)

(defun sdf (l)
(read (strcat "(" l ")"))
)

(defun 3dpoint (p / p0)
(setq p0 (list (car p) (cadr p) (cond ((caddr p)) (t 0.0))))
(mapcar 'read p0)
)

(defun 2dpoint (p / p0)
(setq p0 (list (car p) (cadr p)))
(mapcar 'read p0)
)

(defun anypoint (p)
p
)

(defun toSym (s) ; VM
(if (eq (type s) 'SYM)
(vl-symbol-name s)
(if s s "")
)
)

(defun noz (p)
(list (car p) (cadr p))
)

;; ================================================================
;; (Strtrim )
;;
;; Trims leading and trailing spaces from

(defun strtrim (s)
(Strltrim (Strrtrim s))
)

;; ================================================================
;; (StrLtrim )
;;
;; Trims leading spaces from

(defun Strltrim (s / l)
(if (wcmatch s " *")
(progn
(setq l (1+ (strlen s)) i 1)
(while
(and (eq (substr s i 1) " ")
(/= l i))
(setq i (1+ i))
)
(substr s i)
)
s
)
)

;; ================================================================
;; (StrRtrim )
;;
;; Trims trailing spaces from

(defun Strrtrim (s / i)
(if (wcmatch s "* ")
(progn
(setq i (strlen s))
(while
(and (> i 0)
(eq (substr s i 1) " "))
(setq i (1- i))
)
(substr s 1 i)
)
s
)
)

(defun C:WPOINT ( / ss fd file)
(cond
( (not (setq ss (ssget '((0 . "POINT"))))))
( (not (setq file (getfiled "Export Points" "" "csv" 1))))
( (not (setq fd (open file "w")))
(alert "Unable to open file for output"))
(t (repeat (setq i (sslength ss))
(write-point
(ssname ss (setq i (1- i)))
fd
6
)
)
(close fd)
)
)
(princ)
)

(defun write-point (e fd prec / p)
(setq p (cdr (assoc 10 (entget e))))
(write-line
(strcat (rtos (car p) 2 prec) ","
(rtos (cadr p) 2 prec) ","
(rtos (caddr p) 2 prec)
)
fd
)
)

(princ "\nASCPOINT.LSP Copyright 1990-1997 Tony Tanzillo, mods by CAD Studio")
(princ "\nUse ASCPOINT to import coordinates.")
(princ "\nUse WPOINT to export POINT coordinates.")
(princ)

Block Preview – Lee Mac


;; Block Preview Example Program - Lee Mac
;; Short program to demonstrate DCL Block Preview function

(defun c:bpreview ( / *error* _blockpreview dcl def des lst tmp )

(defun *error* ( msg )
(if (< 0 dcl)
(unload_dialog dcl)
)
(if (= 'file (type des))
(close des)
)
(if (and tmp (findfile tmp))
(vl-file-delete tmp)
)
(if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(defun _blockpreview ( blk )
(start_image "img")
(fill_image 0 0 (dimx_tile "img") (dimy_tile "img") 0)
(LM:BlockPreview "img" blk 5)
(end_image)
)

(while (setq def (tblnext "BLOCK" (null def)))
(if
(and
(= 0 (logand 125 (cdr (assoc 70 def))))
(not (wcmatch (cdr (assoc 2 def)) "`_*,`**,*|*"))
)
(setq lst (cons (cdr (assoc 2 def)) lst))
)
)

(cond
( (null (setq lst (vl-sort lst '<)))
(princ "\nNo blocks found in drawing.")
)
( (null
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(foreach line
'(
"blockpreview : dialog"
"{"
" label = \"Block Preview\";"
" spacer;"
" : row"
" {"
" : list_box { key = \"lst\"; width = 30.0; fixed_width = true; }"
" spacer;"
" : image"
" {"
" key = \"img\";"
" width = 33.5;"
" aspect_ratio = 1.0;"
" fixed_width = true;"
" fixed_height = true;"
" }"
" }"
" spacer;"
" ok_only;"
"}"
)
(write-line line des)
)
(not (setq des (close des)))
(PointList en))
(if (or (= "POINT" (cdr (assoc 0 el))) (vlax-curve-isclosed en))
(setq pl (cons (last pl) pl))
)
(setq ec (_getcolour el))
(setq vl
(append vl
(mapcar
(function
(lambda ( a b )
(list (car a) (cadr a) (car b) (cadr b) ec)
)
)
pl (cdr pl)
)
)
)
)
)
)
)
vl
)

(defun _unique ( l / a r )
(while (setq a (car l))
(setq r (cons a r)
l (vl-remove-if (function (lambda ( b ) (equal a b))) (cdr l))
)
)
(reverse r)
)

(cond
( (or (< margin 0)
(<= (setq xt (dimx_tile key)) (* 2 margin))
(<= (setq yt (dimy_tile key)) (* 2 margin))
)
nil
)
( (setq vl (assoc (strcase block) cache))
(foreach x (cdr vl) (apply 'vector_image x))
t
)
( (setq vl (_getvectors block))
(setq mi (apply 'mapcar (cons 'min vl))
mx (apply 'mapcar (cons 'max vl))
mi (list (min (car mi) (caddr mi)) (min (cadr mi) (cadddr mi)))
mx (list (max (car mx) (caddr mx)) (max (cadr mx) (cadddr mx)))
r1 (/ (- (car mx) (car mi)) (- xt (* 2 margin)))
r2 (/ (- (cadr mx) (cadr mi)) (- yt (* 2 margin)))
)
(cond
( (and (equal r1 r2 1e-8) (equal r1 0.0 1e-8))
(setq sc 1.0
vc (mapcar '- mi (list (/ xt 2.0) (/ yt 2.0)))
)
)
( (equal r1 r2 1e-8)
(setq sc r1
vc (mapcar '(lambda ( x ) (- x (* sc margin))) mi)
)
)
( (PointList ( ent / der di1 di2 di3 elst fun inc lst par rad )
(setq elst (entget ent))
(cond
( (eq "POINT" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)))
)
( (eq "LINE" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)) (cdr (assoc 11 elst)))
)
( (member (cdr (assoc 0 elst)) '("CIRCLE" "ARC"))
(setq di1 0.0
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 (1+ (fix (* 35.0 (/ di2 (cdr (assoc 40 elst)) (+ pi pi))))))
fun (if (vlax-curve-isclosed ent) < <=)
)
(while (fun di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
lst
)
( (or (eq (cdr (assoc 0 elst)) "LWPOLYLINE")
(and (eq (cdr (assoc 0 elst)) "POLYLINE") (zerop (logand (cdr (assoc 70 elst)) 80)))
)
(setq par 0)
(repeat (fix (1+ (vlax-curve-getendparam ent)))
(if (setq der (vlax-curve-getsecondderiv ent par))
(if (equal der '(0.0 0.0 0.0) 1e-8)
(setq lst (cons (vlax-curve-getpointatparam ent par) lst))
(if (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
di1 (vlax-curve-getdistatparam ent par)
di2 (vlax-curve-getdistatparam ent (1+ par))
)
(progn
(setq inc (/ (- di2 di1) (1+ (fix (* 35.0 (/ (- di2 di1) rad (+ pi pi)))))))
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
)
)
)
)
(setq par (1+ par))
)
(if (or (vlax-curve-isclosed ent) (equal '(0.0 0.0 0.0) der 1e-8))
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "ELLIPSE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
di3 (* di2 (/ (+ pi pi) (abs (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)))))
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
der (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1)))
di1 (+ di1 (/ di3 (1+ (fix (/ 35.0 (/ di3 der (+ pi pi)))))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "SPLINE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 25.0)
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
;der (/ (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1))) inc)
di1 (+ di1 inc) ;(+ di1 (if (equal 0.0 der 1e-10) inc (min inc (/ 1.0 der (* 10. inc)))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
)
)

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

(vl-load-com)
(princ)

Pick objects and have their layers set to no plot


;;; Pick objects and have their layers set to no plot.
;;; Created by: Lee Mak 2020
;;; Saved from: https://www.theswamp.org/index.php?topic=55669.0

;;
;; LAYER group codes (added by John Kaul (Se7en) )
;;
;; Group codes - Description
;;
;; 100 - Subclass marker (AcDbLayerTableRecord)
;;
;; 2 - Layer name
;;
;; 70 - Standard flags (bit-coded values):
;; 1 = Layer is frozen; otherwise layer is thawed
;; 2 = Layer is frozen by default in new viewports
;; 4 = Layer is locked
;; 16 = If set, table entry is externally dependent on an xref
;; 32 = If both this bit and bit 16 are set, the externally
;; dependent xref has been successfully resolved
;; 64 = If set, the table entry was referenced by at least
;; one entity in the drawing the last time the drawing
;; was edited. (This flag is for the benefit of AutoCAD
;; commands. It can be ignored by most programs that
;; read DXF files and need not be set by programs that
;; write DXF files)
;;
;; 62 - Color number (if negative, layer is off)
;;
;; 6 - Linetype name
;;
;; 290 - Plotting flag. If set to 0, do not plot this layer
;;
;; 370 - Lineweight enum value
;;
;; 390 - Hard-pointer ID/handle of PlotStyleName object
;;

(defun c:NOP ( / e x )
(while (setq e (car (nentsel "\nSelect object whose layer should not be plotted: ")))
(setq x (entget (tblobjname "layer" (cdr (assoc 8 (entget e))))))
(entmod (subst '(290 . 0) (assoc 290 x) x))
)
(princ)
)
(c:nop)

Make “Paper” background mask for selected texts


(vl-load-com)

; Required ExpressTools

(defun c:TM ( / *error* sel ss sst i enl sse con)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(mapcar 'setvar *BG-VAR* *BG-VAL*)
(setq *BG-doc* nil *BG-VAR* nil *BG-VAL* nil *BG-enl* nil)
(princ))

;(princ "\nSelect Background color:\n\n")
;(setq col (acad_colordlg 7))

(setvar 'OFFSETDIST
(cond ((getdist (strcat "\nSpecify Background width by 2 points on screen : ")))
((getvar 'OFFSETDIST))
)
)

(if (and (setq sel (ssget "_:L" '((0 . "*TEXT"))))
(setq *BG-enl* (entlast))
(setq ss (ssadd))
)

(progn

(vla-startundomark (setq *BG-doc* (vla-get-activedocument (vlax-get-acad-object))))
(setq *BG-VAL* (mapcar 'getvar (setq *BG-VAR* '(CMDECHO OSMODE CLAYER DELOBJ PEDITACCEPT PICKSTYLE))))
(mapcar 'setvar *BG-VAR* '(0 0 "0" 3 1 0))

(setq enl (entlast))
(command "_.COPY" sel "" '(0 0 0) '(0 0 0))
(while (setq enl (entnext enl))
(ssadd enl ss))

(if (setq sst (acet-ss-ssget-filter ss (list (cons 0 (strcat "*LEADER,DIMENSION")))))
(progn
(initcommandversion)
(command "_.EXPLODE" sst ""))) ; creates new lwpolylines,lines,*text,solid,insert

(if (setq sst (acet-ss-ssget-filter ss (list (cons 0 (strcat "INSERT")))))
(LM:burstsel sst t)) ; creates new lwpolylines,lines,*text,solid

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss))) ; revised ss - cleared from removed ents and added new ones

(if (setq sst (acet-ss-ssget-filter ss '((0 . "SOLID")))) ; creates new lwpolylines (flat)
(repeat (setq i (sslength ss))
(:solid2polyline (ssname ss (setq i (1- i))))))

(if (setq sst (acet-ss-ssget-filter ss '((0 . "CIRCLE"))))
(:circle2polyline sst)) ; creates new lwpolylines

(if (setq sst (acet-ss-ssget-filter ss '((0 . "SPLINE"))))
(repeat (setq i (sslength sst))
(command "_.SPLINEDIT" (ssname sst (setq i (1- i))) "_Polyline" 10))) ; creates new lwpolylines

(if (setq sst (acet-ss-ssget-filter ss '((0 . "LINE,ARC"))))
(command "_.PEDIT" "_Multiple" sst "" "")) ; lwpolylines

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss))) ; revised ss - cleard of removed ents and added new ones

(if (setq sst (acet-ss-ssget-filter ss '((0 . "*POLYLINE"))))
(command "_.PEDIT" "_Multiple" sst "" "_Width" (getvar 'OFFSETDIST) ""))

(if (setq sst (acet-ss-ssget-filter ss '((0 . "*TEXT"))))
(progn
(acet-setvar (list "acet_textmask_masktype" "Solid" 3)) ; Save the mask type
(acet-setvar (list "acet_textmask_maskcolor" col 3)) ; and the color
(sssetfirst nil sst)
(vla-sendcommand *BG-doc* (strcat "TEXTMASK\rP\r\r\r\r(BackgroundFinish)\r\r" (chr 27))))
(BackgroundFinish))

))
(princ)
)

; ---------------------------------------------------------------------------- 2ND PART OF MAIN ROUTINE BECAUSE OF VLA-SENDCOMMAND MUST BE THE LAST

(defun BackgroundFinish (/ *error* ss sst enl)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(mapcar 'setvar *BG-VAR* *BG-VAL*)
(vla-endundomark *BG-doc*)
(setq *BG-doc* nil *BG-VAR* nil *BG-VAL* nil *BG-enl* nil)
(princ))

; ----

(if *BG-enl*
(progn

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss)))

(command "_.-LAYER" "_T" "0-BACKGROUND" "_U" "0-BACKGROUND" "_M" "0-BACKGROUND" "_C" "T" "255,255,255" "0-BACKGROUND" ""
"_.CHPROP" ss "" "_Layer" "0-BACKGROUND" "_LType" "_ByLayer" "_Color" "_ByLayer" ""
"_.DRAWORDER" ss "" "_Back"
"_.REGENALL")

(if (setq sst (acet-ss-ssget-filter ss '((-4 . ""))))
(command "_.ERASE" sst ""))

(*error* "end")))
(princ)
)

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

;; beeekeecz

(defun :solid2polyline (ent / lst lay)

(if (and ent
(= "SOLID" (cdr (assoc 0 (entget ent))))
(setq lst (mapcar '(lambda (y) (reverse (cdr (reverse (cdr y)))))
(vl-remove-if-not '(lambda (x) (vl-position (car x) '(10 11 12 13))) (entget ent))))
(setq lst (if (equal (nth 2 lst) (nth 3 lst) 1e-6) ; its triangle
(reverse (cdr (reverse lst)))
(list (nth 0 lst) (nth 1 lst) (nth 3 lst) (nth 2 lst))))
(setq lay (assoc 8 (entget ent)))
(entdel ent)
)
(entmakex (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length lst))
(cons 70 1)
lay)
(mapcar (function (lambda (p) (cons 10 p))) lst)))))

;; Written by Kent Cooper
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/circle-to-polyline-circular-polyline-to-circle/m-p/5520233/highlight/true#M330236
;; Mods by BeekeeCZ to make it subfunc

(defun :circle2polyline (csel / conv cir cdata cctr crad pdata ssnew)

(if (and csel ; User selection
(setq ssnew (ssadd)))
(repeat (sslength csel); then
(setq cir (ssname csel 0); Circle entity name
cdata (entget cir); entity data
cctr (cdr (assoc 10 cdata)); center point, OCS for Circle & LWPolyline w/ WCS 0,0,0 as origin
crad (cdr (assoc 40 cdata)); radius
pdata (vl-remove-if-not '(lambda (x) (member (car x) '(67 410 8 62 6 48 370 39))) cdata)
; start Polyline entity data list -- remove Circle-specific entries from
; Circle's entity data, and extrusion direction; 62 Color, 6 Linetype, 48
; LTScale, 370 LWeight, 39 Thickness present only if not default/bylayer
); setq
(ssadd (entmakex (append '((0 . "LWPOLYLINE")
(100 . "AcDbEntity"))
pdata ; remaining non-entity-type-specific entries
(list '(100 . "AcDbPolyline")
'(90 . 2); # of vertices
(cons 70 (1+ (* 128 (getvar 'plinegen)))); closed [the 1], and uses
; current linetype-generation setting; change above line to
; '(70 . 129) to force linetype generation on, '(70 . 1) to force it off
'(43 . 0.0); global width
(cons 38 (caddr cctr)); elevation in OCS above WCS origin [Z of Circle center]
(cons 10 (list (- (car cctr) crad) (cadr cctr))); vertex 1
'(40 . 0.0) '(41 . 0.0) '(42 . 1); 0 start & end widths, semi-circle bulge factor
(cons 10 (list (+ (car cctr) crad) (cadr cctr))); vertex 2
'(40 . 0.0) '(41 . 0.0) '(42 . 1)
(assoc 210 cdata) ; extr. dir. at end [if in middle, reverts to (210 0.0 0.0 1.0) in (entmake)]
)))
ssnew)
(ssdel cir csel)
(entdel cir)))
ssnew)

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

;;------------------------=={ Burst Upgraded }==------------------------;;
;; ;;
;; This program operates in much the same way as the familiar ;;
;; Express Tools' Burst command, however invisible block attributes ;;
;; are not displayed with the resulting exploded components. ;;
;; ;;
;; Following a valid selection of blocks to burst, the program ;;
;; converts all visible single-line & multi-line attributes into Text ;;
;; and MText respectively, before proceeding to explode the block, ;;
;; and deleting the original attribute objects. ;;
;; ;;
;; The core function accepts a selection set argument and may hence ;;
;; be called from within other custom programs to burst all blocks ;;
;; in a supplied selection set. ;;
;; ;;
;; The methods used by the program should also perform much faster & ;;
;; more efficiently than those used by the Express Tools' Burst.lsp. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2010-11-25 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2013-08-29 ;;
;; ;;
;; - Program entirely rewritten. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2014-02-23 ;;
;; ;;
;; - Program restructured to accept selection set argument. ;;
;; - Program now also explodes non-attributed blocks. ;;
;;----------------------------------------------------------------------;;
;; Version 1.3 - 2015-10-31 ;;
;; ;;
;; - Program modified to account for non-uniformly scaled blocks. ;;
;; - Command syntax changed to 'myburst'. ;;
;;----------------------------------------------------------------------;;
;; Version 1.4 - 2018-01-06 ;;
;; ;;
;; - Program modified to retain visible constant attributes. ;;
;; - Corrected LM:usblock-p function to account for mirrored blocks. ;;
;;----------------------------------------------------------------------;;
;; Version 1.5 - 2018-07-09 ;;
;; ;;
;; - Accounted for multiline attributes whose text content occupies ;;
;; multiple group 1 & 3 DXF groups. ;;
;;----------------------------------------------------------------------;;
;; Version 1.6 - 2018-12-10 ;;
;; ;;
;; - Accounted for invisible objects created when bursting dynamic ;;
;; blocks with visibility states. ;;
;; - Fixed bug causing attributes with transparency to be removed. ;;
;; - Integrated Nested Burst program. ;;
;;----------------------------------------------------------------------;;
;; Version 1.7 - 2018-12-22 ;;
;; ;;
;; - Accounted for nested xrefs (excluding them from burst operation). ;;
;;----------------------------------------------------------------------;;

(defun c:pburst nil (LM:burst nil))
(defun c:nburst nil (LM:burst t))

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

(defun LM:burst ( nst / *error* )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(LM:burstsel
(LM:ssget "\nSelect blocks to burst: "
(list "_:L"
(append '((0 . "INSERT"))
(
(lambda ( / def lst )
(while (setq def (tblnext "block" (null def)))
(if (= 4 (logand 4 (cdr (assoc 70 def))))
(setq lst (vl-list* "," (cdr (assoc 2 def)) lst))
)
)
(if lst (list '(-4 . "")))
)
)
(if (= 1 (getvar 'cvport))
(list (cons 410 (getvar 'ctab)))
'((410 . "Model"))
)
)
)
)
nst
)
(LM:endundo (LM:acdoc)) (princ)
)

(defun LM:burstsel ( sel nst / idx )
(if (= 'pickset (type sel))
(repeat (setq idx (sslength sel))
(LM:burstobject (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) nst)
)
)
)

(defun LM:burstobject ( obj nst / cmd col ent err lay lin lst qaf tmp )
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(not (vlax-property-available-p obj 'path))
(vlax-write-enabled-p obj)
(or (and (LM:usblock-p obj)
(not (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vlax-invoke (list obj 'explode)))))
(setq lst err)
)
(progn
(setq tmp (vla-copy obj)
ent (LM:entlast)
cmd (getvar 'cmdecho)
qaf (getvar 'qaflags)
)
(setvar 'cmdecho 0)
(setvar 'qaflags 0)
(vl-cmdf "_.explode" (vlax-vla-object->ename tmp))
(setvar 'qaflags qaf)
(setvar 'cmdecho cmd)
(while (setq ent (entnext ent))
(setq lst (cons (vlax-ename->vla-object ent) lst))
)
lst
)
)
)
(progn
(setq lay (vla-get-layer obj)
col (vla-get-color obj)
lin (vla-get-linetype obj)
)
(foreach att (vlax-invoke obj 'getattributes)
(if (vlax-write-enabled-p att)
(progn
(if (= "0" (vla-get-layer att))
(vla-put-layer att lay)
)
(if (= acbyblock (vla-get-color att))
(vla-put-color att col)
)
(if (= "byblock" (strcase (vla-get-linetype att) t))
(vla-put-linetype att lin)
)
)
)
(if
(and
(= :vlax-false (vla-get-invisible att))
(= :vlax-true (vla-get-visible att))
)
( (if (and (vlax-property-available-p att 'mtextattribute) (= :vlax-true (vla-get-mtextattribute att)))
LM:burst:matt2mtext
LM:burst:att2text
)
(entget (vlax-vla-object->ename att))
)
)
)
(foreach new lst
(cond
( (not (vlax-write-enabled-p new)))
( (= :vlax-false (vla-get-visible new))
(vla-delete new)
)
( t
(if (= "0" (vla-get-layer new))
(vla-put-layer new lay)
)
(if (= acbyblock (vla-get-color new))
(vla-put-color new col)
)
(if (= "byblock" (strcase (vla-get-linetype new) t))
(vla-put-linetype new lin)
)
(if (= "AcDbAttributeDefinition" (vla-get-objectname new))
(progn
(if
(and
(= :vlax-true (vla-get-constant new))
(= :vlax-false (vla-get-invisible new))
)
( (if (and (vlax-property-available-p new 'mtextattribute) (= :vlax-true (vla-get-mtextattribute new)))
LM:burst:matt2mtext
LM:burst:att2text
)
(entget (vlax-vla-object->ename new))
)
)
(vla-delete new)
)
(if nst (LM:burstobject new nst))
)
)
)
)
(vla-delete obj)
)
)
)

(defun LM:burst:removepairs ( itm lst )
(vl-remove-if '(lambda ( x ) (member (car x) itm)) lst)
)

(defun LM:burst:remove1stpairs ( itm lst )
(vl-remove-if '(lambda ( x ) (if (member (car x) itm) (progn (setq itm (vl-remove (car x) itm)) t))) lst)
)

(defun LM:burst:att2text ( enx )
(entmakex
(append '((0 . "TEXT"))
(LM:burst:removepairs '(000 002 003 070 074 100 280 440)
(subst (cons 73 (cdr (assoc 74 enx))) (assoc 74 enx) enx)
)
)
)
)

(defun LM:burst:matt2mtext ( enx )
(entmakex
(append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
(LM:burst:remove1stpairs
(if (= "ATTDEF" (cdr (assoc 0 enx)))
'(001 003 007 010 040 041 050 071 072 073 210)
'(001 007 010 040 041 050 071 072 073 210)
)
(LM:burst:removepairs '(000 002 011 042 043 051 070 074 100 101 102 280 330 360 440) enx)
)
(list (assoc 011 (reverse enx)))
)
)
)

;; 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 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
(list 'abs (list 'vlax-get-property 'obj (strcat "y" s)))
1e-8
)
(list 'equal
(list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
(list 'abs (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)
;;;(princ
;;; (strcat
;;; "\n:: BurstUpgraded.lsp | Version 1.7 | \\U+00A9 Lee Mac "
;;; (menucmd "m=$(edtime,0,yyyy)")
;;; " http://www.lee-mac.com ::"
;;; "\n:: \"pburst\" to burst primary | \"nburst\" to burst primary + nested ::"
;;; )
;;;)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:tm)