;;; Draw "Background" Mask under entities selected by user
;;; Based on routine created by BeekeeCZ and saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-avode-double-selection/td-p/8495611
;;; Combined and Deeply modified by Igal Averbuh 2019
;;; Used Lee Mak Burst Upgraded routine http://www.lee-mac.com/upgradedburst.html
;;; Finaly modified by BeekeeCZ https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-avode-double-selection/td-p/8495611/page/2
(vl-load-com)
; Required ExpressTools
(defun c:BG ( / *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))
(if (and (setq sel (ssget "_:L" '((0 . "*TEXT,*POLYLINE,*LEADER,DIMENSION,INSERT,SPLINE,LINE,ARC,CIRCLE"))))
(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* '(1 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"))))
(command "_.ERASE" sst ""))
(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" 1 ""))
(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" 42 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" 42 "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)
)
;; --------------------------------------------------------------------------------------------------------------------------------------
;; --------------------------------------------------------------------------------------------------------------------------------------
;; 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 ::"
;;; ""
;;; )
;;;)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
