;;------------------------=={ 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))
        (if (not (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 )
    (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                              ;;
;;----------------------------------------------------------------------;;