1. ;;;炸开选择中所有块，块炸到底
  2. (defun c:bx()
  3.   (setvar "qaflags" 1)
  4.   (setq SS (ssget '((0 . "INSERT"))))
  5.   (setq n1 0)
  6.   (while (> (sslength SS) 0)
  7.     (command "explode" SS "")
  8.     (setq SB1 (ssget "p"))
  9.     (setq n2 0)
  10.     (setq SS (ssadd))
  11.     (repeat (sslength SB1)
  12.       (setq en(ssname SB1 n2))
  13.       (setq endata(entget en))
  14.       (setq entype (cdr (assoc 0 endata)))
  15.       (if (= entype "INSERT")  (setq SS (ssadd en SS)))
  16.       (setq n2 (1+ n2))
  17.       )
  18.     (setq n1 (1+ n1))
  19.     )  
  20.   (setvar "qaflags" 0)
  21.   (princ)
  22. )
  25. ;;;块刷
  26. (defun c:bc ( / old_cmd old_ent ss n e1 ee m)
  28.   (if (not (setq old_ent (ssget "_:S:E:L" '((0 . "INSERT"))))) (exit))
  29.   (setq old_ent (ssname old_ent 0))
  30.   (redraw old_ent 3)
  31.   (princ "\n 选择需被替换的块:")
  32.   (if (not (setq ss (ssget '((0 . "INSERT"))))) (exit))
  33.   (setq ee (assoc 2 (entget old_ent))
  34.         n (sslength ss)
  35.         m (itoa n)
  36.   )
  37.   (repeat n
  38.           (setq n (1- n) e1 (entget (ssname ss n)))
  39.           (entmod (subst ee (assoc 2 e1) e1))
  40.   )
  41.   (princ (strcat "\n " m " 个块被替换."))
  42. )
  44. (defun c:xx (/ *error* ss qf) 
  45.   (defun *error* (msg) 
  46.     (setvar "qaflags" qf)
  47.     (princ msg)
  48.     (princ)
  49.   )
  50.   (setq qf (getvar "qaflags"))
  51.   (setvar "qaflags" 1)
  52.   (princ "\n炸块")
  53.   (setq ss (ssget '((0 . "INSERT"))))
  54.   (while (setq ss (ssget "P" '((0 . "INSERT")))) 
  55.     (command ".explode" ss "")
  56.   )
  57.   (setvar "qaflags" qf)
  58.   (princ)
  59. )

G版_超级炸弹

  1. (VL-LOAD-COM)
  2. (setq *SYSVARNL* (LIST 'AUNITS 'AUPREC 'ATTDIA 'ATTREQ 'BLIPMODE 'DIMZIN 'CECOLOR 
  3.                        'CELTYPE 'CLAYER 'CMDECHO 'TRIMMODE 'EXPERT 'HIGHLIGHT 'LUNITS 
  4.                        'LUPREC 'EDGEMODE 'OSMODE 'ORTHOMODE 'TEXTSTYLE 'PLINEWID 'PLINEGEN 
  5.                        'FILEDIA 'PICKBOX 'QAFLAGS 'UCSAXISANG 'CELTSCALE 'NOMUTT 
  6.                        'PEDITACCEPT 'MIRRTEXT 'LIMCHECK
  7.                  )
  8. )
  9. (setq *ACAD* (vlax-get-acad-object))
  10. (setq *ACDOCUMENT* (vla-get-ActiveDocument *ACAD*))
  11. (setq *MODEL-SPACE* (vla-get-ModelSpace *ACDOCUMENT*))
  12. (setq *PAPER-SPACE* (vla-get-PaperSpace *ACDOCUMENT*))
  13. (setq PI2 (* PI 0.5))
  14. (setq PI4 (* PI 0.25))
  15. (setq 2PI (* PI 2.0))
  16. (setq 3PI2 (* 1.5 PI))
  17. (setq 3PI4 (+ PI2 PI4))
  18. (setq 5PI4 (+ PI PI4))
  19. (setq 7PI4 (+ 3PI2 PI4))
  20. (setq PI6 (/ PI 6))
  21. (setq 2PI3 (/ PI 3 0.5))
  22. (setq #ZJWS# 2)
  23. (setq *JD* 1.0e-005)
  24. (setq EN2OBJ vlax-ename->vla-object)
  25. (setq OBJ2EN vlax-vla-object->ename)
  26. (setq *SPACE* (vlax-get-property *ACDOCUMENT* 
  27.                                  (if (= 1 (GETVAR 'CVPORT)) 
  28.                                    (PROGN 'PAPERSPACE)
  29.                                    (PROGN 'MODELSPACE)
  30.                                  )
  31.               )
  32. )
  33. (MAPCAR 'VL-ARX-IMPORT 
  34.         '(ACAD_COLORDLG ACAD_TRUECOLORDLG ACAD_STRLSORT INITDIA acad-pop-dbmod 
  35.           acad-push-dbmod STARTAPP LAYOUTLIST BPOLY
  36.          )
  37. )
  38. (DEFUN GXL-ITEM (COLL ITEM) 
  39.   (if 
  40.     (NOT 
  41.       (VL-CATCH-ALL-ERROR-P 
  42.         (setq ITEM (VL-CATCH-ALL-APPLY 'vla-Item (LIST COLL ITEM)))
  43.       )
  44.     )
  45.     (PROGN ITEM)
  46.   )
  47. )
  48. (DEFUN GXL-SYS-PROGRESS-DONE () 
  49.   (setq *PROGRESSID* 0)
  50.   (setq *PROGRESSTO* nil)
  51.   (setq *PROGRESSPROMPT* "")
  52.   (setq *PROGRESSBFB* 2)
  53.   (setq *FLAGINIT* nil)
  54.   (SETVAR "modemacro" "")
  55. )
  56. (DEFUN GXL-CATCHAPPLY (FUN ARGS / RESULT) 
  57.   (if 
  58.     (NOT 
  59.       (VL-CATCH-ALL-ERROR-P 
  60.         (setq RESULT (VL-CATCH-ALL-APPLY 
  61.                        (if (= 'SYM (TYPE FUN)) (PROGN FUN) (PROGN 'FUN))
  62.                        ARGS
  63.                      )
  64.         )
  65.       )
  66.     )
  67.     (PROGN RESULT)
  68.   )
  69. )
  70. (DEFUN GXL-REUCS (/ OBJUCS) 
  71.   (if 
  72.     (setq OBJUCS (GXL-CATCHAPPLY 
  73.                    vla-Item
  74.                    (LIST (vla-get-UserCoordinateSystems *ACDOCUMENT*) "OldUCS")
  75.                  )
  76.     )
  77.     (PROGN (vla-put-ActiveUCS *ACDOCUMENT* OBJUCS))
  78.     (PROGN (command "_.ucs") (command ""))
  79.   )
  80.   (PRINC)
  81. )
  82. (DEFUN REERR () 
  83.   (GXL-REUCS)
  84.   (if 
  85.     (OR (= 'LIST (TYPE *ERROR*)) 
  86.         (= 'SUBR (TYPE *ERROR*))
  87.         (= 'USUBR (TYPE *ERROR*))
  88.     )
  89.     (PROGN 
  90.       (MAPCAR '(lambda (A B) (VL-CATCH-ALL-APPLY 'SETVAR (LIST A B))) 
  91.               *SYSVARNL*
  92.               (REVERSE *SVARL*)
  93.       )
  94.       (setq *ERROR* MYOLD*ERROR*)
  95.     )
  96.     (PROGN (ALERT "ERROR  : NO (SETIERR)!"))
  97.   )
  98.   (if (= 8 (LOGAND (GETVAR "undoctl") 8)) (PROGN (vla-EndUndoMark *ACDOCUMENT*)))
  99.   (GC)
  100.   (PRINC)
  101. )
  102. (DEFUN GXL-PT->3D (P) 
  103.   (COND 
  104.     ((= 'LIST (TYPE P))
  105.      (if (= 1 (LENGTH P)) 
  106.        (PROGN 
  107.          (LIST 
  108.            (if (= 'REAL (TYPE (CAR P))) 
  109.              (PROGN (CAR P))
  110.              (PROGN (ATOF (ITOA (CAR P))))
  111.            )
  112.            0.0
  113.            0.0
  114.          )
  115.        )
  116.        (PROGN 
  117.          (if (= 2 (LENGTH P)) 
  118.            (PROGN 
  119.              (LIST 
  120.                (if (= 'REAL (TYPE (CAR P))) 
  121.                  (PROGN (CAR P))
  122.                  (PROGN (ATOF (ITOA (CAR P))))
  123.                )
  124.                (if (= 'REAL (TYPE (CADR P))) 
  125.                  (PROGN (CADR P))
  126.                  (PROGN (ATOF (ITOA (CADR P))))
  127.                )
  128.                0.0
  129.              )
  130.            )
  131.            (PROGN 
  132.              (LIST 
  133.                (if (= 'REAL (TYPE (CAR P))) 
  134.                  (PROGN (CAR P))
  135.                  (PROGN (ATOF (ITOA (CAR P))))
  136.                )
  137.                (if (= 'REAL (TYPE (CADR P))) 
  138.                  (PROGN (CADR P))
  139.                  (PROGN (ATOF (ITOA (CADR P))))
  140.                )
  141.                (if (= 'REAL (TYPE (CADDR P))) 
  142.                  (PROGN (CADDR P))
  143.                  (PROGN (ATOF (ITOA (CADDR P))))
  144.                )
  145.              )
  146.            )
  147.          )
  148.        )
  149.      )
  150.     )
  151.     ((= 'REAL (TYPE P)) (LIST P 0.0 0.0))
  152.     ((= 'INT (TYPE P)) (LIST (ATOF (ITOA P)) 0.0 0.0))
  153.     (T nil)
  154.   )
  155. )
  156. (DEFUN GXL-PT->SHIFT (PT @PT) 
  157.   (setq PT (GXL-PT->3D PT))
  158.   (setq @PT (GXL-PT->3D @PT))
  159.   (APPLY 'MAPCAR (CONS '+ (LIST PT @PT)))
  160. )
  161. (DEFUN GXL-SETWCS (/ OBJUCS UCSORG UCSXDIR UCSYDIR) 
  162.   (if (= 0 (GETVAR "worlducs")) 
  163.     (PROGN (setq UCSORG (GETVAR "ucsorg")) 
  164.            (setq UCSXDIR (GXL-PT->SHIFT UCSORG (GETVAR "ucsxdir")))
  165.            (setq UCSYDIR (GXL-PT->SHIFT UCSORG (GETVAR "ucsydir")))
  166.            (setq OBJUCS (VL-CATCH-ALL-APPLY 'vla-Item 
  167.                                             (LIST (vla-get-UserCoordinateSystems *ACDOCUMENT* ) 
  168.                                                   "OldUCS"
  169.                                             )
  170.                         )
  171.            )
  172.            (VL-CMDF "_.ucs" "")
  173.            (if (NOT (VL-CATCH-ALL-ERROR-P OBJUCS)) (PROGN (vla-Delete OBJUCS)))
  174.            (VL-CATCH-ALL-APPLY 'vla-Add 
  175.                                (LIST (vla-get-UserCoordinateSystems *ACDOCUMENT*) 
  176.                                      (vlax-3d-point UCSORG)
  177.                                      (vlax-3d-point UCSXDIR)
  178.                                      (vlax-3d-point UCSYDIR)
  179.                                      "OldUCS"
  180.                                )
  181.            )
  182.     )
  183.     (PROGN 
  184.       (setq OBJUCS (VL-CATCH-ALL-APPLY 'vla-Item 
  185.                                        (LIST (vla-get-UserCoordinateSystems *ACDOCUMENT* ) 
  186.                                              "OldUCS"
  187.                                        )
  188.                    )
  189.       )
  190.       (if (NOT (VL-CATCH-ALL-ERROR-P OBJUCS)) 
  191.         (PROGN (VL-CATCH-ALL-APPLY 'vla-Delete (LIST OBJUCS)))
  192.       )
  193.     )
  194.   )
  195.   (PRINC)
  196. )
  197. (DEFUN SETIERR (/ SV 0LAY OS) 
  198.   (vla-put-Lock (GXL-ITEM (vla-get-Layers *ACDOCUMENT*) "0") :vlax-false)
  199.   (if (OR (= 'LIST (TYPE *ERROR*)) (= 'USUBR (TYPE *ERROR*))) 
  200.     (PROGN (ALERT "ERROR  :THE LAST (SETiERR) FUNCTION HAS NO (ReErr)!"))
  201.     (PROGN (setq *SVARL* nil) 
  202.            (FOREACH SV *SYSVARNL* (setq *SVARL* (CONS (GETVAR SV) *SVARL*)))
  203.            (FOREACH SV 
  204.              '("ATTDIA" "ATTREQ" "BLIPMODE" "CMDECHO" "DIMZIN" "OSMODE" "ORTHOMODE" 
  205.                "MIRRTEXT"
  206.               )
  207.              (if (= SV "OSMODE") 
  208.                (PROGN 
  209.                  (if (< (setq OS (GETVAR "OSMODE")) 16384) 
  210.                    (PROGN (SETVAR "OSMODE" (+ OS 16384)))
  211.                  )
  212.                )
  213.                (PROGN (SETVAR SV 0))
  214.              )
  215.            )
  216.            (vla-StartUndoMark *ACDOCUMENT*)
  217.            (SETVAR "EXPERT" 5)
  218.            (SETVAR "CECOLOR" "BYLAYER")
  219.            (SETVAR "celtype" "BYLAYER")
  220.            (SETVAR "LWDISPLAY" 1)
  221.            (SETVAR "CELTSCALE" 1)
  222.            (SETVAR "PLINEGEN" 1)
  223.            (setq MYOLD*ERROR* *ERROR*)
  224.            (DEFUN *ERROR* (ST) 
  225.              (while (and (/= (GETVAR 'CMDACTIVE) 0)) (command ""))
  226.              (GXL-SYS-PROGRESS-DONE)
  227.              (if ERRSEL (PROGN (command "erase") (command ERRSEL) (command "")))
  228.              (vla-EndUndoMark *ACDOCUMENT*)
  229.              (REERR)
  230.              (PRINC ST)
  231.            )
  232.     )
  233.   )
  234.   (GXL-SETWCS)
  235.   (setq *MODEL-SPACE* (vlax-get-property *ACDOCUMENT* 
  236.                                          (if (= 1 (GETVAR 'CVPORT)) 
  237.                                            (PROGN 'PAPERSPACE)
  238.                                            (PROGN 'MODELSPACE)
  239.                                          )
  240.                       )
  241.   )
  242. )
  243. (DEFUN GXL-SEL-MAPCAR (SS FUN / NN RTN) 
  244.   (if SS 
  245.     (PROGN 
  246.       (REPEAT (setq NN (SSLENGTH SS)) 
  247.         (setq RTN (CONS (APPLY FUN (LIST (SSNAME SS (setq NN (1- NN))))) RTN))
  248.       )
  249.     )
  250.   )
  251. )
  252. (DEFUN GXL-LISTP (LST) (AND (VL-CONSP LST) (VL-LIST-LENGTH LST)))
  253. (DEFUN GXL-DXF (ENT I) 
  254.   (if (= (TYPE ENT) 'ENAME) (PROGN (setq ENT (ENTGET ENT '("*")))))
  255.   (COND 
  256.     ((ATOM I) (CDR (ASSOC I ENT)))
  257.     ((GXL-LISTP I) (MAPCAR '(LAMBDA (X) (CDR (ASSOC X ENT))) I))
  258.   )
  259. )
  260. (DEFUN GXL-ITEMSALL (COLLECTION / RESULT) 
  261.   (VL-CATCH-ALL-APPLY 
  262.     '(lambda () 
  263.        (VLAX-FOR ITEM COLLECTION (setq RESULT (CONS ITEM RESULT)))
  264.        (REVERSE RESULT)
  265.      )
  266.   )
  267.   RESULT
  268. )
  269. (DEFUN GXL-STRPARSE (STR DEL / POS LST) 
  270.   (while (and (setq POS (VL-STRING-SEARCH DEL STR))) 
  271.     (setq LST (CONS (SUBSTR STR 1 POS) LST))
  272.     (setq STR (SUBSTR STR (+ POS 1 (STRLEN DEL))))
  273.   )
  274.   (if (= " " DEL) 
  275.     (PROGN (VL-REMOVE "" (REVERSE (CONS STR LST))))
  276.     (PROGN (REVERSE (CONS STR LST)))
  277.   )
  278. )
  279. (DEFUN GXL-SEL-SS->VLA (SS / I L) 
  280.   (if SS 
  281.     (PROGN 
  282.       (REPEAT (setq I (SSLENGTH SS)) 
  283.         (setq L (CONS (vlax-ename->vla-object (SSNAME SS (setq I (1- I)))) L))
  284.       )
  285.     )
  286.   )
  287. )
  288. (DEFUN GXL-SEL-ENTNEXTALL (ENT / SS) 
  289.   (if (NOT ENT) 
  290.     (PROGN (setq ENT (ENTNEXT)) 
  291.            (if ENT (PROGN (setq SS (SSADD ENT))) (PROGN (setq SS (SSADD))))
  292.     )
  293.     (PROGN (setq SS (SSADD)))
  294.   )
  295.   (while (and (setq ENT (ENTNEXT ENT))) 
  296.     (if (NOT (MEMBER (CDR (ASSOC 0 (ENTGET ENT))) '("ATTRIB" "VERTEX" "SEQEND"))) 
  297.       (PROGN (SSADD ENT SS))
  298.     )
  299.   )
  300.   (if (= 0 (SSLENGTH SS)) (PROGN nil) (PROGN SS))
  301. )
  302. (DEFUN GXL-CH_ENT (ENT I PT / EN) 
  303.   (if (ASSOC I (setq EN (ENTGET ENT))) 
  304.     (PROGN (setq EN (SUBST (CONS I PT) (ASSOC I EN) EN)))
  305.     (PROGN (setq EN (APPEND EN (LIST (CONS I PT)))))
  306.   )
  307.   (ENTMOD EN)
  308. )
  309. (DEFUN GXL-SUPPEREXPLODEBLOCK (EN / SUPPEREXPLODEBLOCK SS LASTEN LAYER BLKREF) 
  310.   (DEFUN SUPPEREXPLODEBLOCK (OBJ PARLST / ORIGIN X Y Z R INSERTPT COPYENT ATTS 
  311.                              STYLENAME DXF BLKOBJ E0 TXTOBJ TMP COPYS ROW COL ROWSPC 
  312.                              COLSPC
  313.                             ) 
  314.     (setq ORIGIN (vlax-3d-point '(0 0 0)))
  315.     (if 
  316.       (OR (= "AcDbBlockReference" (vla-get-ObjectName OBJ)) 
  317.           (= "AcDbMInsertBlock" (vla-get-ObjectName OBJ))
  318.       )
  319.       (PROGN (setq X (vla-get-XScaleFactor OBJ)) 
  320.              (setq Y (vla-get-YScaleFactor OBJ))
  321.              (setq Z (vla-get-ZScaleFactor OBJ))
  322.              (setq R (vla-get-Rotation OBJ))
  323.              (setq INSERTPT (vla-get-InsertionPoint OBJ))
  324.              (setq COPYENT (vlax-invoke *ACDOCUMENT* 
  325.                                         'COPYOBJECTS
  326.                                         (VL-REMOVE-IF 
  327.                                           '(LAMBDA (X) 
  328.                                              (= "AcDbAttributeDefinition" 
  329.                                                 (vla-get-ObjectName X)
  330.                                              )
  331.                                            )
  332.                                           (GXL-ITEMSALL 
  333.                                             (vla-Item (vla-get-Blocks *ACDOCUMENT*) 
  334.                                                       (vla-get-Name OBJ)
  335.                                             )
  336.                                           )
  337.                                         )
  338.                                         *MODEL-SPACE*
  339.                            )
  340.              )
  341.              (if (= "AcDbMInsertBlock" (vla-get-ObjectName OBJ)) 
  342.                (PROGN (setq ROW (vla-get-Rows OBJ)) 
  343.                       (setq ROWSPC (/ (vla-get-RowSpacing OBJ) Y))
  344.                       (setq COL (vla-get-Columns OBJ))
  345.                       (setq COLSPC (/ (vla-get-ColumnSpacing OBJ) X))
  346.                       (setq TMP nil)
  347.                       (setq COPYS COPYENT)
  348.                       (REPEAT (1- ROW) 
  349.                         (setq COPYS (MAPCAR 'vla-Copy COPYS))
  350.                         (MAPCAR 
  351.                           '(LAMBDA (M) 
  352.                              (vla-Move M 
  353.                                        ORIGIN
  354.                                        (vlax-3d-point 
  355.                                          (POLAR (QUOTE (0 0 0)) PI2 ROWSPC)
  356.                                        )
  357.                              )
  358.                            )
  359.                           COPYS
  360.                         )
  361.                         (setq TMP (APPEND TMP COPYS))
  362.                       )
  363.                       (setq COPYS (APPEND COPYENT TMP))
  364.                       (REPEAT (1- COL) 
  365.                         (setq COPYS (MAPCAR 'vla-Copy COPYS))
  366.                         (MAPCAR 
  367.                           '(LAMBDA (M) 
  368.                              (vla-Move M 
  369.                                        ORIGIN
  370.                                        (vlax-3d-point 
  371.                                          (POLAR (QUOTE (0 0 0)) 0 COLSPC)
  372.                                        )
  373.                              )
  374.                            )
  375.                           COPYS
  376.                         )
  377.                         (setq TMP (APPEND TMP COPYS))
  378.                       )
  379.                       (setq COPYENT (APPEND COPYENT TMP))
  380.                )
  381.              )
  382.              (if (vla-get-HasAttributes OBJ) 
  383.                (PROGN (setq ATTS (vlax-invoke OBJ 'GETATTRIBUTES)) 
  384.                       (FOREACH ATT ATTS 
  385.                         (setq STYLENAME (LAST 
  386.                                           (GXL-STRPARSE 
  387.                                             (vla-get-StyleName ATT)
  388.                                             "|"
  389.                                           )
  390.                                         )
  391.                         )
  392.                         (setq DXF (ENTGET (vlax-vla-object->ename ATT)))
  393.                         (setq DXF (MEMBER '(100 . "AcDbEntity") DXF))
  394.                         (setq DXF (CDR 
  395.                                     (MEMBER '(100 . "AcDbAttribute") 
  396.                                             (REVERSE DXF)
  397.                                     )
  398.                                   )
  399.                         )
  400.                         (setq DXF (CONS '(0 . "TEXT") (REVERSE DXF)))
  401.                         (MAPCAR 
  402.                           '(LAMBDA (X) (SETQ DXF (VL-REMOVE (ASSOC X DXF) DXF)))
  403.                           '(-1 5 330 7)
  404.                         )
  405.                         (setq DXF (SUBST (CONS 8 (GETVAR "clayer")) 
  406.                                          (ASSOC 8 DXF)
  407.                                          DXF
  408.                                   )
  409.                         )
  410.                         (setq DXF (SUBST (CONS 62 256) (ASSOC 62 DXF) DXF))
  411.                         (ENTMAKE DXF)
  412.                         (vla-put-StyleName (setq TXTOBJ (vlax-ename->vla-object (ENTLAST ) )) 
  413.                                            STYLENAME
  414.                         )
  415.                         (SUPPEREXPLODEBLOCK TXTOBJ PARLST)
  416.                       )
  417.                )
  418.              )
  419.              (vla-Delete OBJ)
  420.              (setq PARLST (CONS (LIST X Y Z R INSERTPT) PARLST))
  421.              (FOREACH AOBJ COPYENT 
  422.                (if 
  423.                  (OR (= "AcDbBlockReference" (vla-get-ObjectName AOBJ)) 
  424.                      (= "AcDbMInsertBlock" (vla-get-ObjectName AOBJ))
  425.                  )
  426.                  (PROGN 
  427.                    (if (vla-get-HasAttributes AOBJ) 
  428.                      (PROGN (setq ATTS (vlax-invoke AOBJ 'GETATTRIBUTES)) 
  429.                             (FOREACH ATT ATTS 
  430.                               (setq STYLENAME (LAST 
  431.                                                 (GXL-STRPARSE 
  432.                                                   (vla-get-StyleName ATT)
  433.                                                   "|"
  434.                                                 )
  435.                                               )
  436.                               )
  437.                               (setq DXF (ENTGET (vlax-vla-object->ename ATT)))
  438.                               (setq DXF (MEMBER '(100 . "AcDbEntity") DXF))
  439.                               (setq DXF (CDR 
  440.                                           (MEMBER '(100 . "AcDbAttribute") 
  441.                                                   (REVERSE DXF)
  442.                                           )
  443.                                         )
  444.                               )
  445.                               (setq DXF (CONS '(0 . "TEXT") (REVERSE DXF)))
  446.                               (MAPCAR 
  447.                                 '(LAMBDA (X) 
  448.                                    (SETQ DXF (VL-REMOVE (ASSOC X DXF) DXF))
  449.                                  )
  450.                                 '(-1 5 330 7)
  451.                               )
  452.                               (setq DXF (SUBST (CONS 8 (GETVAR "clayer")) 
  453.                                                (ASSOC 8 DXF)
  454.                                                DXF
  455.                                         )
  456.                               )
  457.                               (setq DXF (SUBST (CONS 62 256) (ASSOC 62 DXF) DXF))
  458.                               (ENTMAKE DXF)
  459.                               (vla-put-StyleName (vlax-ename->vla-object (ENTLAST)) 
  460.                                                  STYLENAME
  461.                               )
  462.                               (SUPPEREXPLODEBLOCK 
  463.                                 (vlax-ename->vla-object (ENTLAST))
  464.                                 PARLST
  465.                               )
  466.                             )
  467.                      )
  468.                    )
  469.                    (SUPPEREXPLODEBLOCK AOBJ PARLST)
  470.                  )
  471.                  (PROGN (setq COPYENT (LIST AOBJ)) 
  472.                         (MAPCAR 
  473.                           '(LAMBDA (PARS / X Y Z R INSERTPT BLKOBJ E0) 
  474.                              (SETQ X        (CAR PARS)
  475.                                    Y        (CADR PARS)
  476.                                    Z        (CADDR PARS)
  477.                                    R        (CADDDR PARS)
  478.                                    INSERTPT (LAST PARS)
  479.                              )
  480.                              (SETQ BLKOBJ (vla-Add (vla-get-Blocks *ACDOCUMENT*) 
  481.                                                    ORIGIN
  482.                                                    "*U"
  483.                                           )
  484.                              )
  485.                              (vlax-invoke *ACDOCUMENT* 
  486.                                           (QUOTE COPYOBJECTS)
  487.                                           COPYENT
  488.                                           BLKOBJ
  489.                              )
  490.                              (MAPCAR (QUOTE vla-Delete) COPYENT)
  491.                              (vla-InsertBlock *MODEL-SPACE* 
  492.                                               INSERTPT
  493.                                               (vla-get-Name BLKOBJ)
  494.                                               X
  495.                                               Y
  496.                                               Z
  497.                                               R
  498.                              )
  499.                              (COMMAND "_.explode" (SETQ E0 (ENTLAST)))
  500.                              (vla-Delete BLKOBJ)
  501.                              (SETQ COPYENT (GXL-SEL-SS->VLA 
  502.                                              (GXL-SEL-ENTNEXTALL E0)
  503.                                            )
  504.                              )
  505.                            )
  506.                           PARLST
  507.                         )
  508.                  )
  509.                )
  510.              )
  511.       )
  512.       (PROGN (setq COPYENT (LIST OBJ)) 
  513.              (MAPCAR 
  514.                '(LAMBDA (PARS / X Y Z R INSERTPT BLKOBJ E0) 
  515.                   (SETQ X        (CAR PARS)
  516.                         Y        (CADR PARS)
  517.                         Z        (CADDR PARS)
  518.                         R        (CADDDR PARS)
  519.                         INSERTPT (LAST PARS)
  520.                   )
  521.                   (SETQ BLKOBJ (vla-Add (vla-get-Blocks *ACDOCUMENT*) ORIGIN "*U"))
  522.                   (vlax-invoke *ACDOCUMENT* (QUOTE COPYOBJECTS) COPYENT BLKOBJ)
  523.                   (MAPCAR (QUOTE vla-Delete) COPYENT)
  524.                   (vla-InsertBlock *MODEL-SPACE* 
  525.                                    INSERTPT
  526.                                    (vla-get-Name BLKOBJ)
  527.                                    X
  528.                                    Y
  529.                                    Z
  530.                                    R
  531.                   )
  532.                   (COMMAND "_.explode" (SETQ E0 (ENTLAST)))
  533.                   (vla-Delete BLKOBJ)
  534.                   (SETQ COPYENT (GXL-SEL-SS->VLA (GXL-SEL-ENTNEXTALL E0)))
  535.                 )
  536.                PARLST
  537.              )
  538.       )
  539.     )
  540.   )
  541.   (if (= 'ENAME (TYPE EN)) 
  542.     (PROGN (setq BLKREF (vlax-ename->vla-object EN)))
  543.     (PROGN (setq BLKREF EN) (setq EN (vlax-vla-object->ename EN)))
  544.   )
  545.   (if 
  546.     (AND (= "INSERT" (GXL-DXF EN 0)) 
  547.          (NOT 
  548.            (= 4 
  549.               (LOGAND 
  550.                 (CDR 
  551.                   (ASSOC 70 
  552.                          (ENTGET (TBLOBJNAME "block" (CDR (ASSOC 2 (ENTGET EN)))))
  553.                   )
  554.                 )
  555.                 4
  556.               )
  557.            )
  558.          )
  559.     )
  560.     (PROGN (setq LASTEN (ENTLAST)) 
  561.            (setq LAYER (vla-get-Layer BLKREF))
  562.            (SUPPEREXPLODEBLOCK BLKREF nil)
  563.            (setq SS (GXL-SEL-ENTNEXTALL LASTEN))
  564.            (GXL-SEL-MAPCAR SS '(LAMBDA (X) (GXL-CH_ENT X 8 LAYER)))
  565.            SS
  566.     )
  567.     (PROGN (SSADD EN))
  568.   )
  569. )
  570. (DEFUN GXL-ASSOC (KEY ALIST / VAL) (CDR (ASSOC KEY ALIST)))
  571. (DEFUN GXL-BLK-VXGETATTS (OBJ) 
  572.   (if (= (TYPE OBJ) 'ENAME) (PROGN (setq OBJ (vlax-ename->vla-object OBJ))))
  573.   (MAPCAR '(LAMBDA (ATT) (CONS (vla-get-TagString ATT) (vla-get-TextString ATT))) 
  574.           (vlax-invoke OBJ "GetAttributes")
  575.   )
  576. )
  577. (DEFUN GXL-CODESTRIP (ENTL STRIPLST) 
  578.   (VL-REMOVE-IF '(LAMBDA (A) (VL-POSITION (CAR A) STRIPLST)) ENTL)
  579. )
  580. (DEFUN GXL-STR-SUBST (NEW OLD STR / STR1 N) 
  581.   (setq N (STRLEN OLD))
  582.   (COND 
  583.     ((> (STRLEN STR) N)
  584.      (setq STR1 (SUBSTR STR 1 N))
  585.      (if (= STR1 OLD) 
  586.        (PROGN (STRCAT NEW (GXL-STR-SUBST NEW OLD (SUBSTR STR (1+ N)))))
  587.        (PROGN (STRCAT (SUBSTR STR 1 1) (GXL-STR-SUBST NEW OLD (SUBSTR STR 2))))
  588.      )
  589.     )
  590.     ((= (STRLEN STR) N) (if (= OLD STR) (PROGN NEW) (PROGN STR)))
  591.     (T STR)
  592.   )
  593. )
  594. (DEFUN GXL-BLK-CHECK (B_NAME / $PROMPT B_NAME1 CURLAY ERR) 
  595.   (if (OR (= 'SUBR (TYPE MAKEBLOCK-001)) (= 'USUBR (TYPE MAKEBLOCK-001))) 
  596.     (PROGN)
  597.     (PROGN (setq $PROMPT (LOAD "MakeBlockSymbol.vlx" "未找到MakeBlockSymbol.vlx文件")))
  598.   )
  599.   (if (= $PROMPT "未找到MakeBlockSymbol.vlx文件") 
  600.     (PROGN 
  601.       (setq $PROMPT (LOAD "E:\\lisp\\房产CAD工具软件\\lisp\\MakeBlockSymbol.vlx" 
  602.                           "未找到MakeBlockSymbol.vlx文件"
  603.                     )
  604.       )
  605.     )
  606.   )
  607.   (if (= $PROMPT "未找到MakeBlockSymbol.vlx文件") 
  608.     (PROGN B_NAME)
  609.     (PROGN (setq B_NAME1 (GXL-STR-SUBST "]" ")" (GXL-STR-SUBST "[" "(" B_NAME))) 
  610.            (setq CURLAY (GETVAR "Clayer"))
  611.            (setq ERR (VL-CATCH-ALL-APPLY 'vla-Item 
  612.                                          (LIST (vla-get-Blocks *ACDOCUMENT*) 
  613.                                                B_NAME
  614.                                          )
  615.                      )
  616.            )
  617.            (if (VL-CATCH-ALL-ERROR-P ERR) 
  618.              (PROGN 
  619.                (if 
  620.                  (OR (= 'USUBR (TYPE (EVAL (READ (STRCAT "MakeBlock-" B_NAME1))))) 
  621.                      (= 'SUBR (TYPE (EVAL (READ (STRCAT "MakeBlock-" B_NAME1)))))
  622.                  )
  623.                  (PROGN (EVAL (READ (STRCAT "(MakeBlock-" B_NAME1 ")"))))
  624.                )
  625.              )
  626.            )
  627.            (SETVAR "clayer" CURLAY)
  628.            B_NAME
  629.     )
  630.   )
  631. )
  632. (DEFUN GXL-AX:INSERTBLOCK (INSPT NAME XSCALE YSCALE ZSCALE ROTATION) 
  633.   (GXL-BLK-CHECK NAME)
  634.   (SETVAR "insname" (VL-FILENAME-BASE NAME))
  635.   (VL-CATCH-ALL-APPLY 'vla-InsertBlock 
  636.                       (LIST *MODEL-SPACE* 
  637.                             (vlax-3d-point (TRANS INSPT 1 0))
  638.                             NAME
  639.                             XSCALE
  640.                             YSCALE
  641.                             ZSCALE
  642.                             ROTATION
  643.                       )
  644.   )
  645. )
  646. (DEFUN GXL-BLK-VXSETATTS (OBJ LST / ATTVAL) 
  647.   (if (= (TYPE OBJ) 'ENAME) (PROGN (setq OBJ (vlax-ename->vla-object OBJ))))
  648.   (MAPCAR 
  649.     '(LAMBDA (ATT) 
  650.        (IF (SETQ ATTVAL (CDR (ASSOC (vla-get-TagString ATT) LST))) 
  651.          (vla-put-TextString ATT ATTVAL)
  652.        )
  653.      )
  654.     (vlax-invoke OBJ "GetAttributes")
  655.   )
  656.   (vla-Update OBJ)
  657.   (PRINC)
  658. )
  659. (DEFUN GXL-BLK-MINSERT->INSERT (EN / FLAG FLAG1 ENL ROT XSCALE YSCALE ZSCALE COL ROW 
  660.                                 COLDIS ROWDIS INSPT NEWENLST I II COLPT ROWPT NAME 
  661.                                 ATTS SS
  662.                                ) 
  663.   (if 
  664.     (AND EN 
  665.          (if (= 'VLA-OBJECT (TYPE EN)) 
  666.            (PROGN (setq EN (vlax-vla-object->ename EN)))
  667.            (PROGN EN)
  668.          )
  669.          (= "INSERT" (CDR (ASSOC 0 (setq ENL (ENTGET EN '("*"))))))
  670.          (= "AcDbMInsertBlock" (CDR (ASSOC 100 (MEMBER (ASSOC 8 ENL) ENL))))
  671.     )
  672.     (PROGN (setq SS (SSADD)) 
  673.            (setq ROT (GXL-ASSOC 50 ENL))
  674.            (setq XSCALE (GXL-ASSOC 41 ENL))
  675.            (setq YSCALE (GXL-ASSOC 42 ENL))
  676.            (setq ZSCALE (GXL-ASSOC 43 ENL))
  677.            (setq COL (GXL-ASSOC 70 ENL))
  678.            (setq ROW (GXL-ASSOC 71 ENL))
  679.            (setq COLDIS (GXL-ASSOC 44 ENL))
  680.            (setq ROWDIS (GXL-ASSOC 45 ENL))
  681.            (setq INSPT (GXL-ASSOC 10 ENL))
  682.            (setq NAME (GXL-ASSOC 2 ENL))
  683.            (setq ATTS (GXL-BLK-VXGETATTS EN))
  684.            (setq NEWENLST (GXL-CODESTRIP ENL '(-1 330 5 70 71 44 45)))
  685.            (setq NEWENLST (SUBST '(100 . "AcDbBlockReference") 
  686.                                  '(100 . "AcDbMInsertBlock")
  687.                                  NEWENLST
  688.                           )
  689.            )
  690.            (setq I 0)
  691.            (REPEAT COL 
  692.              (setq COLPT (POLAR INSPT ROT (* I COLDIS)))
  693.              (setq II 0)
  694.              (REPEAT ROW 
  695.                (setq ROWPT (POLAR COLPT (+ ROT PI2) (* II ROWDIS)))
  696.                (setq OBJ (GXL-AX:INSERTBLOCK ROWPT NAME XSCALE YSCALE ZSCALE ROT))
  697.                (command "_matchprop")
  698.                (command EN)
  699.                (command (ENTLAST))
  700.                (command "")
  701.                (SSADD (ENTLAST) SS)
  702.                (if ATTS (PROGN (GXL-BLK-VXSETATTS OBJ ATTS)))
  703.                (setq II (1+ II))
  704.              )
  705.              (setq I (1+ I))
  706.            )
  707.            (ENTDEL EN)
  708.            SS
  709.     )
  710.     (PROGN (SSADD EN))
  711.   )
  712. )
  713. (DEFUN GXL-SEL-SS->LIST (SS / I S) 
  714.   (if SS 
  715.     (PROGN 
  716.       (REPEAT (setq I (SSLENGTH SS)) (setq S (CONS (SSNAME SS (setq I (1- I))) S)))
  717.     )
  718.   )
  719. )
  720. (DEFUN GXL-CODESTRIPFIRST (LST STRIPLST) 
  721.   (if LST 
  722.     (PROGN 
  723.       (if STRIPLST 
  724.         (PROGN 
  725.           (if (VL-POSITION (CAAR LST) STRIPLST) 
  726.             (PROGN (GXL-CODESTRIPFIRST (CDR LST) (VL-REMOVE (CAAR LST) STRIPLST)))
  727.             (PROGN (CONS (CAR LST) (GXL-CODESTRIPFIRST (CDR LST) STRIPLST)))
  728.           )
  729.         )
  730.         (PROGN LST)
  731.       )
  732.     )
  733.   )
  734. )
  735. (DEFUN GXL-MATT2MTEXT (ELIST / EL) 
  736.   (setq EL (ENTGET (CDR (ASSOC 330 ELIST))))
  737.   (setq ELIST (SUBST (ASSOC 8 EL) (ASSOC 8 ELIST) ELIST))
  738.   (if (ASSOC 66 EL) 
  739.     (PROGN (setq ELIST (SUBST (ASSOC 66 EL) (ASSOC 66 ELIST) ELIST)))
  740.   )
  741.   (ENTMAKEX 
  742.     (APPEND '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText")) 
  743.             (GXL-CODESTRIPFIRST 
  744.               (GXL-CODESTRIP ELIST '(102 330 360 0 100 101 2 42 43 51 74 70 280))
  745.               '(40 1 50 41 7 71 72 71 72 73 10 11 11 210)
  746.             )
  747.     )
  748.   )
  749. )
  750. (DEFUN GXL-ATT2TEXT (ELIST / EL) 
  751.   (setq EL (ENTGET (CDR (ASSOC 330 ELIST))))
  752.   (setq ELIST (SUBST (ASSOC 8 EL) (ASSOC 8 ELIST) ELIST))
  753.   (if (ASSOC 66 EL) 
  754.     (PROGN (setq ELIST (SUBST (ASSOC 66 EL) (ASSOC 66 ELIST) ELIST)))
  755.   )
  756.   ((lambda (DXF74) 
  757.      (ENTMAKEX 
  758.        (APPEND '((0 . "TEXT")) 
  759.                (GXL-CODESTRIP 
  760.                  (SUBST (CONS 73 DXF74) (ASSOC 74 ELIST) ELIST)
  761.                  '(0 100 2 74 70 280)
  762.                )
  763.        )
  764.      )
  765.    ) 
  766.     (CDR (ASSOC 74 ELIST))
  767.   )
  768. )
  769. (DEFUN GXL-EXPLODEBLOCK (EN / DOC MSPACE BLKS BLNAME BLKREF BLKDEF OBJLST OBJ INSPT 
  770.                          OBJARRAY OBJ ATTS OBJARRAY1 ATT DATA DATA1 DATA2 RTN SS 
  771.                          XSCALE YSCALE ZSCALE ROTATION NEWEN ENLAST RTN1
  772.                         ) 
  773.   (setq DOC (vla-get-ActiveDocument (vlax-get-acad-object)))
  774.   (setq MSPACE (vla-get-ModelSpace DOC))
  775.   (setq BLKS (vla-get-Blocks DOC))
  776.   (setq FLAG T)
  777.   (SETVAR "cecolor" "ByLayer")
  778.   (if (= 'VLA-OBJECT (TYPE EN)) (PROGN (setq EN (vlax-vla-object->ename EN))))
  779.   (setq SS (GXL-BLK-MINSERT->INSERT EN))
  780.   (setq SS (GXL-SEL-SS->LIST SS))
  781.   (FOREACH EN SS 
  782.     (if (= "INSERT" (GXL-DXF EN 0)) 
  783.       (PROGN 
  784.         (if 
  785.           (= :vlax-true 
  786.              (vla-get-HasAttributes (setq OBJ (vlax-ename->vla-object EN)))
  787.           )
  788.           (PROGN 
  789.             (setq ATTS (vlax-safearray->list (vlax-variant-value (vla-GetAttributes OBJ ) ) ))
  790.           )
  791.         )
  792.         (if ATTS 
  793.           (PROGN 
  794.             (FOREACH ATT ATTS 
  795.               (if (/= "" (vla-get-TextString ATT)) 
  796.                 (PROGN 
  797.                   (if vla-get-MTextAttribute 
  798.                     (PROGN 
  799.                       (if (= :vlax-true (vla-get-MTextAttribute ATT)) 
  800.                         (PROGN 
  801.                           (GXL-MATT2MTEXT (ENTGET (vlax-vla-object->ename ATT)))
  802.                         )
  803.                         (PROGN (GXL-ATT2TEXT (ENTGET (vlax-vla-object->ename ATT))) )
  804.                       )
  805.                     )
  806.                     (PROGN (GXL-ATT2TEXT (ENTGET (vlax-vla-object->ename ATT))))
  807.                   )
  808.                   (setq OBJARRAY1 (CONS (vlax-ename->vla-object (ENTLAST)) 
  809.                                         OBJARRAY1
  810.                                   )
  811.                   )
  812.                 )
  813.               )
  814.             )
  815.           )
  816.         )
  817.         (setq INSPT (GXL-DXF EN 10))
  818.         (setq LAY (GXL-DXF EN 8))
  819.         (setq XSCALE (GXL-DXF EN 41))
  820.         (setq YSCALE (GXL-DXF EN 42))
  821.         (setq ZSCALE (GXL-DXF EN 42))
  822.         (setq ROTATION (GXL-DXF EN 50))
  823.         (setq BLKNAME (vla-get-Name (setq BLKREF (vlax-ename->vla-object EN))))
  824.         (if 
  825.           (= "AcDbBlockReference" (vla-get-ObjectName (vlax-ename->vla-object EN)))
  826.           (PROGN (setq ENLAST (ENTLAST)) (command "_.explode") (command EN))
  827.           (PROGN (ENTDEL EN) 
  828.                  (setq ENLAST (ENTLAST))
  829.                  (GXL-AX:INSERTBLOCK INSPT BLKNAME XSCALE YSCALE ZSCALE ROTATION)
  830.                  (command "_.explode")
  831.                  (command (ENTLAST))
  832.           )
  833.         )
  834.         (setq SS1 (GXL-SEL-ENTNEXTALL ENLAST))
  835.         (setq SS1 (GXL-SEL-SS->LIST SS1))
  836.         (setq SS1 (MAPCAR 'vlax-ename->vla-object SS1))
  837.         (MAPCAR '(LAMBDA (X) (vla-put-Layer X LAY)) SS1)
  838.         (setq RTN (APPEND RTN (APPEND OBJARRAY1 SS1)))
  839.       )
  840.       (PROGN (setq RTN (APPEND RTN (LIST (vlax-ename->vla-object EN)))))
  841.     )
  842.   )
  843.   (setq RTN (VL-REMOVE-IF 
  844.               '(LAMBDA (X) 
  845.                  (IF (= "AcDbAttributeDefinition" (vla-get-ObjectName X)) 
  846.                    (PROGN (vla-Delete X) T)
  847.                  )
  848.                )
  849.               RTN
  850.             )
  851.   )
  852.   (FOREACH A RTN 
  853.     (if 
  854.       (OR (= "AcDbInsertBlock" (vla-get-ObjectName A)) 
  855.           (= "AcDbMInsertBlock" (vla-get-ObjectName A))
  856.           (= "AcDbBlockReference" (vla-get-ObjectName A))
  857.       )
  858.       (PROGN (setq RTN1 (APPEND RTN1 (GXL-EXPLODEBLOCK (vlax-vla-object->ename A)))) )
  859.       (PROGN (setq RTN1 (APPEND RTN1 (LIST A))))
  860.     )
  861.   )
  862.   RTN1
  863. )
  864. (DEFUN GXL-NUM-AX->LISPVALUE (V) 
  865.   (COND 
  866.     ((= (TYPE V) 'variant) (GXL-NUM-AX->LISPVALUE (vlax-variant-value V)))
  867.     ((= (TYPE V) 'safearray) (MAPCAR 'GXL-NUM-AX->LISPVALUE (safearray-value V)))
  868.     ((= (TYPE V) 'LIST) (MAPCAR 'GXL-NUM-AX->LISPVALUE V))
  869.     (T V)
  870.   )
  871. )
  872. (DEFUN GXL-SEL-SSUNION (SSLIST) 
  873.   (MAPCAR 
  874.     '(LAMBDA (X / C) 
  875.        (SETQ C -1)
  876.        (REPEAT (SSLENGTH X) (SSADD (SSNAME X (SETQ C (1+ C))) (CAR SSLIST)))
  877.      )
  878.     (CDR SSLIST)
  879.   )
  880.   (SSLENGTH (CAR SSLIST))
  881. )
  882. (DEFUN GXL-SEL-LIST->SS (LST / EN SS KK) 
  883.   (setq SS (SSADD))
  884.   (setq KK 0)
  885.   (FOREACH EN LST (SSADD EN SS) (setq KK (1+ KK)))
  886.   SS
  887. )
  888. (DEFUN GXL-EXPLODE (SS / OBJ ERR SSRTN EN SS1 SELRTN) 
  889.   (setq SELRTN (SSADD))
  890.   (COND 
  891.     ((= 'ENAME (TYPE SS))
  892.      (setq OBJ (vlax-ename->vla-object SS))
  893.      (COND 
  894.        ((OR (= "AcDbMInsertBlock" (vla-get-ObjectName OBJ)) 
  895.             (= "AcDbBlockReference" (vla-get-ObjectName OBJ))
  896.         )
  897.         (setq SSRTN (APPEND SSRTN (GXL-EXPLODEBLOCK OBJ)))
  898.        )
  899.        ((OR (= "AcDb3dPolyline" (vla-get-ObjectName OBJ)) 
  900.             (= "AcDb2dPolyline" (vla-get-ObjectName OBJ))
  901.             (= "AcDbPolyline" (vla-get-ObjectName OBJ))
  902.             (= "AcDbModelerGeometry" (vla-get-ObjectName OBJ))
  903.         )
  904.         (setq ERR (VL-CATCH-ALL-APPLY 'vla-Explode (LIST OBJ)))
  905.         (if (VL-CATCH-ALL-ERROR-P ERR) 
  906.           (PROGN (setq SSRTN (CONS OBJ SSRTN)))
  907.           (PROGN (setq SSRTN (APPEND SSRTN (GXL-NUM-AX->LISPVALUE ERR))) 
  908.                  (vla-Delete OBJ)
  909.           )
  910.         )
  911.        )
  912.        ((OR (WCMATCH (STRCASE (vla-get-ObjectName OBJ)) "*DIMENSION") 
  913.             (= "AcDbHatch" (vla-get-ObjectName OBJ))
  914.         )
  915.         (setq EN (ENTLAST))
  916.         (command "_.explode")
  917.         (command (vlax-vla-object->ename OBJ))
  918.         (GXL-SEL-SSUNION (LIST SELRTN (GXL-SEL-ENTNEXTALL EN)))
  919.        )
  920.        (T (setq SSRTN (CONS OBJ SSRTN)))
  921.      )
  922.     )
  923.     ((= 'PICKSET (TYPE SS))
  924.      (setq SS (MAPCAR 'vlax-ename->vla-object (GXL-SEL-SS->LIST SS)))
  925.      (FOREACH OBJ SS 
  926.        (COND 
  927.          ((OR (= "AcDbMInsertBlock" (vla-get-ObjectName OBJ)) 
  928.               (= "AcDbBlockReference" (vla-get-ObjectName OBJ))
  929.           )
  930.           (setq SSRTN (APPEND SSRTN (GXL-EXPLODEBLOCK OBJ)))
  931.          )
  932.          ((OR (= "AcDb3dPolyline" (vla-get-ObjectName OBJ)) 
  933.               (= "AcDb2dPolyline" (vla-get-ObjectName OBJ))
  934.               (= "AcDbPolyline" (vla-get-ObjectName OBJ))
  935.               (= "AcDbModelerGeometry" (vla-get-ObjectName OBJ))
  936.           )
  937.           (setq ERR (VL-CATCH-ALL-APPLY 'vla-Explode (LIST OBJ)))
  938.           (if (VL-CATCH-ALL-ERROR-P ERR) 
  939.             (PROGN (setq SSRTN (CONS OBJ SSRTN)))
  940.             (PROGN (setq SSRTN (APPEND SSRTN (GXL-NUM-AX->LISPVALUE ERR))) 
  941.                    (vla-Delete OBJ)
  942.             )
  943.           )
  944.          )
  945.          ((OR (WCMATCH (STRCASE (vla-get-ObjectName OBJ)) "*DIMENSION") 
  946.               (= "AcDbHatch" (vla-get-ObjectName OBJ))
  947.           )
  948.           (setq EN (ENTLAST))
  949.           (command "_.explode")
  950.           (command (vlax-vla-object->ename OBJ))
  951.           (GXL-SEL-SSUNION (LIST SELRTN (GXL-SEL-ENTNEXTALL EN)))
  952.          )
  953.          (T (setq SSRTN (CONS OBJ SSRTN)))
  954.        )
  955.      )
  956.     )
  957.   )
  958.   (GXL-SEL-SSUNION 
  959.     (LIST SELRTN (GXL-SEL-LIST->SS (MAPCAR 'vlax-vla-object->ename SSRTN)))
  960.   )
  961.   SELRTN
  962. )
  963. (vl-ACAD-defun 
  964.   (DEFUN C:SUP_EXP (/ SS FLAG) 
  965.     (SETIERR)
  966.     (while (and (setq SS (SSGET))) 
  967.       (GXL-SEL-MAPCAR 
  968.         SS
  969.         '(lambda (X) 
  970.            (if (= "INSERT" (GXL-DXF X 0)) 
  971.              (PROGN (GXL-SUPPEREXPLODEBLOCK X))
  972.              (PROGN (GXL-EXPLODE X))
  973.            )
  974.          )
  975.       )
  976.     )
  977.     (REERR)
  978.     (PRINC)
  979.   )
  980. )
  981. 'C:SUP_EXP
  982. (PRINC "\n超级炸弹，一炸到底 By Gu_xl 命令: Sup_exp")
  983. (PRINC)