;;------------------------=={ 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  -  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:lm_nburst nil (princ "\n无限炸开嵌套块。") (LM:burst   t))

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

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

	(mai_last_com "lm_nburst")

	(defun *error* ( msg )
		(LM:endundo (LM:acdoc))
		(or (wcmatch (strcase msg t) "*break,*cancel*,*exit*")
			(princ (strcat "\nError: " msg))
		)
		(princ)
	)
	
	(LM:startundo (LM:acdoc))
	(LM:burstsel
		(LM:ssget "\n选择需要匹配的块:"
			(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 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>")))
						)
					)
					(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 att new )
	(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)
)

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