;link.lsp (version 16d) ; ; (Note: in my example, I am using one line and one circle.) ; ; ; COMMAND DESCRIPTION ;------------------------------------------------------------------------------ ; (setq a (ssget)) imports entities into selection group a. ; ; (setq b (entget (ssname a 0) )) tells us everything about the 1st entity ; in selection group a. Everything about this ; entity is stored in b. For example if we are ; dealing with a line, then b will contain ; values for starting coordinates and ending ; coordinates, layer, linetype etc. On the ; other hand if we are dealing with a circle, ; then b contains radius, center coordinates ; etc. Each of these values (radius etc) are ; pointed to by a preceding code called the ; associative code. For example, the value ; immediately behind associative code 10 ; is the starting coordinates for a line. ; So we get hold of b, look into it for ; associate code 10, and we know that the ; three numbers immediately after it are ; the X, Y, and Z coordinates for the starting ; end of that line. Similarly associative ; code 0 points to the type of entity we are ; looking at. Again we get hold of b, look into ; it for associative code 0, and if the string ; straight after it says "LINE" then we know ; it is a line we are dealing with, if it says ; "CIRCLE" then it is a circle and so on. ; ; (setq b (entget (ssname a 1) )) tells us everything about the 2nd entity ; in selection group a, and so on. ; ; (setq n (sslength a)) tells us the number of entities in the group a. ; This is useful for loops, so that we know when ; to exit loop. ; ; (setq d (cdr (assoc 0 b) )) looks into entity b, finds associate code 0, and ; tells us the value it points to. For example, ; in the case ( 0 . "CIRCLE" ), the value of d we ; get here will be "CIRCLE". ; How is this useful? Say we have a entity ; but are not sure its type, eg. a line, a circle, ; an arc etc.. Well, this command quickly tells us ; it's a circle. ; This command can be broken down into two parts: ; (setq c (assoc 0 b)) which gives ( 0 . "CIRCLE" ) ; and (setq d (cdr c )) which gives "CIRCLE". ; (setq r (cdr (assoc 40 b) )) gets the radius of the circle and stores the ; value in r. ; ; (setq d (cadr (assoc 10 b))) tells us the x coordinate of for example ; (10 16719.6 2997.79 0.0) that represents the ; starting end of a line. ; Command comes from: ; (setq c (assoc 10 b)) which gives us ; (10 16719.6 2997.79 0.0), and, ; (setq d (cadr c)) which gives us 16719.6 ; (setq d (cadr (cdr (assoc 10 b)))) tells us the y coordinate of that point. ; This command comes from: ; (setq c (assoc 10 b)) which gives us ; (10 16719.6 2997.79 0.0), and secondly, ; (setq p (cdr c)) to get rid of the 10 and come to ; (16719.6 2997.79 0.0), and finally, ; (setq d (cadr p)) to get us the middle 2997.79 ; ; (setq txt (cdr (assoc 1 b))) string content of text ; (setq xi (cadr (assoc 10 b))) insertion x of text ; (setq yi (cadr (cdr (assoc 10 b)))) insertion y of text ; ; ; Associative Code Meaning ;------------------------------------------------------------------------------ ; 0 Type (eg, line, circle, arc) ; 1 Text content (the string itself) ; 10 Starting coordinates of line or ; Center of circle or ; Insertion point of text. ; 11 Finishing coordinates of line ; 40 Radius of circle or ; Height or text. ; 50 Rotation angle of text (default is set to 0) (defun c:ct() (princ "\n ***** |U¢XE3I£gu?ZA¡Ò3s1/2u *****") (setq relay 0) (while (/= relay -1) ;start of infinte loop (refresh) ; to clear all variables and set bug detectors (if (= relay 0) (progn (prompt "\n[ Window Selection 1 ] ") (setq corner1 (getpoint)) (setq corner2 (getcorner corner1)) ) ;end of if relay 0 progn for true case (progn (prompt "\n[ Continuation from ] ") (setq corner1 corner3) (setq corner2 corner4) ) ;end of if relay 0 progn for ELSE case ) ;end of if relay 0 (setq feed1 corner1) (setq feed2 corner2) (setq gate "firstpass") (explode) (explode) (setq a (ssget "w" corner1 corner2)) ; selection data a (prompt "\n[ Window Selection 2 ] ") (setq corner3 (getpoint)) (setq corner4 (getcorner corner3)) (setq feed1 corner3) (setq feed2 corner4) (setq gate "firstpass") (explode) (explode) (setq aa (ssget "w" corner3 corner4)) ; selection data aa (setq mm (sslength a)) ; number of entities in a (setq nn (sslength aa)) ; number of entities in aa (setq sd 999999999) ; default smallestDistance (outerLoop) ; Start the game (setq point1 (list lockX1 lockY1 0.0)) (setq point2 (list lockX2 lockY2 0.0)) (princ "\n[ Shortest Distance ] = ") (princ point1) (princ " -> ") (princ point2) (princ "\n") (command "line" point1 point2 "") ; Final touch to completion (relaygame) ) ;end of infinite repetition loop (princ) ;to get rid of the end nil ) ; end of main ;start of innerLoop [this is the group selected first] (defun innerLoop() (setq k 0) (repeat mm (progn (setq b (entget (ssname a k) )) ; b data (setq t (cdr (assoc 0 b) )) ; t is entity type (if (= t "CIRCLE") (progn ; Handling CIRCLE (setq r (cdr (assoc 40 b) )) ; r is radius of circle (setq x (cadr (assoc 10 b) )) ; x value of center of circle (setq y (cadr (cdr (assoc 10 b)))) ; y value of center of circle (setq p (assoc 10 b) ) (setq o (cdr p ) ) ; o is the center coordinates (setq q1 (polar o 0 r) ) ; 3 o'clock quadrant point (setq x (car q1)) (setq y (cadr q1)) (checkdist) (setq q2 (polar o (/ pi 4) r) ) ; 1:30 o'clock (setq x (car q2)) (setq y (cadr q2)) (checkdist) (setq q3 (polar o (/ pi 2) r) ) ; 12 o'clock (setq x (car q3)) (setq y (cadr q3)) (checkdist) (setq q4 (polar o (* (/ pi 4) 3) r) ); 10:30 o'clock (setq x (car q4)) (setq y (cadr q4)) (checkdist) (setq q5 (polar o pi r) ) ; 9 o'clock (setq x (car q5)) (setq y (cadr q5)) (checkdist) (setq q6 (polar o (* (/ pi 4) -3) r) ) ; 7:30 o'clock (setq x (car q6)) (setq y (cadr q6)) (checkdist) (setq q7 (polar o (/ pi -2) r) ) ; 6 o'clock (setq x (car q7)) (setq y (cadr q7)) (checkdist) (setq q8 (polar o (/ pi -4) r) ) ; 4:30 o'clock (setq x (car q8)) (setq y (cadr q8)) (checkdist) );end of progn );end of if circle innerLoop (if (= t "LINE") (progn ; Handling LINE (setq x1 (cadr (assoc 10 b))) ; starting x (setq y1 (cadr (cdr (assoc 10 b)))) ; starting y (setq x2 (cadr (assoc 11 b))) ; ending x (setq y2 (cadr (cdr (assoc 11 b)))) ; ending y (setq x ( / (+ x1 x2) 2 ) ) (setq y ( / (+ y1 y2) 2 ) ) ; mid point coordinates (checkdist) );end of progn );end of if line onnerLoop (if (= t "TEXT") (progn ; Handling TEXT (setq b (entget (ssname a 2) )) ; b is text data (setq t (cdr (assoc 0 b) )) ; t is entity type (setq txt (cdr (assoc 1 b))) ; string content of text (setq x (cadr (assoc 10 b))) ; insertion x of text (setq y (cadr (cdr (assoc 10 b)))) ; insertion y of text (checkdist) );end of progn );end of if text innerLoop ) ;end of progn (setq k (+ k 1)) ) ;end of repeat mm ) ;end of innerLoop ;start of outerLoop [This is the group selected second] (defun outerLoop() (setq kk 0) (repeat nn (progn (setq bb (entget (ssname aa kk) )) (setq tt (cdr (assoc 0 bb) )) (if (= tt "CIRCLE") (progn ; Handling CIRCLE (setq rr (cdr (assoc 40 bb) )) (setq xx (cadr (assoc 10 bb) )) (setq yy (cadr (cdr (assoc 10 bb)))) (setq pp (assoc 10 bb) ) (setq oo (cdr pp ) ) (setq qq1 (polar oo 0 rr) ) (setq xx (car qq1)) (setq yy (cadr qq1)) (innerLoop) (setq qq2 (polar oo (/ pi 4) rr) ) (setq xx (car qq2)) (setq yy (cadr qq2)) (innerLoop) (setq qq3 (polar oo (/ pi 2) rr) ) (setq xx (car qq3)) (setq yy (cadr qq3)) (innerLoop) (setq qq4 (polar oo (* (/ pi 4) 3) rr) ) (setq xx (car qq4)) (setq yy (cadr qq4)) (innerLoop) (setq qq5 (polar oo pi rr) ) (setq xx (car qq5)) (setq yy (cadr qq5)) (innerLoop) (setq qq6 (polar oo (* (/ pi 4) -3) rr) ) (setq xx (car qq6)) (setq yy (cadr qq6)) (innerLoop) (setq qq7 (polar oo (/ pi -2) rr) ) (setq xx (car qq7)) (setq yy (cadr qq7)) (innerLoop) (setq qq8 (polar oo (/ pi -4) rr) ) (setq xx (car qq8)) (setq yy (cadr qq8)) (innerLoop) );end of progn );end of if circle outerLoop (if (= tt "LINE") (progn ; Handling LINE (setq xx1 (cadr (assoc 10 bb))) (setq yy1 (cadr (cdr (assoc 10 bb)))) (setq xx2 (cadr (assoc 11 bb))) (setq yy2 (cadr (cdr (assoc 11 bb)))) (setq xx ( / (+ xx1 xx2) 2 ) ) (setq yy ( / (+ yy1 yy2) 2 ) ) (innerLoop) );end of progn );end of if line outerLoop (if (= tt "TEXT") (progn ; Handling TEXT (setq bb (entget (ssname aa 2) )) (setq tt (cdr (assoc 0 bb) )) (setq ttxt (cdr (assoc 1 bb))) (setq xx (cadr (assoc 10 bb))) (setq yy (cadr (cdr (assoc 10 bb)))) (innerLoop) );end of progn text );end of if text outerLoop ) ;end of progn outerloop (setq kk (+ kk 1)) ) ;end of repeat nn-1 ) ;end of outerLoop ;start of function checkdist (defun checkdist() (setq dist2 (sqrt (+ (* (- x xx) (- x xx)) (* (- y yy) (- y yy))))) (if (< dist2 sd) (progn (setq sd dist2) (setq lockX1 x) (setq lockX2 xx) (setq lockY1 y) (setq lockY2 yy) );end of progn );end of if );end of checkdist ;start of refresh to clear variables (defun refresh() (setq q1 "bug_detector") (setq q2 "bug_detector") (setq q3 "bug_detector") (setq q4 "bug_detector") (setq q5 "bug_detector") (setq q6 "bug_detector") (setq q7 "bug_detector") (setq q8 "bug_detector") (setq qq1 "bug_detector") (setq qq2 "bug_detector") (setq qq3 "bug_detector") (setq qq4 "bug_detector") (setq qq5 "bug_detector") (setq qq6 "bug_detector") (setq qq7 "bug_detector") (setq qq8 "bug_detector") (setq x1 "bug_detector") (setq x2 "bug_detector") (setq y1 "bug_detector") (setq y2 "bug_detector") (setq x "bug_detector") (setq y "bug_detector") (setq xx "bug_detector") (setq yy "bug_detector") (setq dist2 "bug_detector") (setq lockX1 "bug_detector") (setq lockX2 "bug_detector") (setq lockY1 "bug_detector") (setq lockY2 "bug_detector") (setq a "bug_detector") (setq aa "bug_detector") (setq b "bug_detector") (setq bb "bug_detector") (setq t "bug_detector") (setq tt "bug_detector") (setq r "bug_detector") (setq rr "bug_detector") (setq o "bug_detector") (setq oo "bug_detector") (setq k "bug_detector") (setq kk "bug_detector") (setq mm "bug_detector") ;originally just called n (setq nn "bug_detector") (setq b "bug_detector") (setq bb "bug_detector") (setq p "bug_detector") (setq pp "bug_detector") (setq sd "bug_detector") (setq txt "bug_detector") (setq ttxt "bug_detector") (setq point1 "bug_detector") (setq point2 "bug_detector") ) ;end of refreshment ;A bit of entertainment using the relay variable. Resets everytime AutoCAD ;is reopened (defun relaygame() (if (= relay nil) (setq relay 0)) (if (= hiscore nil) (setq hiscore 0)) (if (= oldscore nil) (setq oldscore 0)) (setq relay (+ relay 1)) (setq oldscore hiscore) (if (< relay 3) (setq hiscore (+ hiscore 1)) ) (if (= relay 3) (setq hiscore (+ hiscore 5)) ) (if (> relay 3) (setq hiscore (+ hiscore 10)) ) (princ "3sAo3s?F ") (princ relay) (princ " ¡Óo1/2u <¢D[ ") (princ (- hiscore oldscore)) (princ " ?A> <¢DO?eA`?A ") (princ hiscore) (princ "> ¢D[ao! \\(^^)/ ¢D[ao! ?¢G-n¢D¡¦2V¢G? \n") ) ; end of relaygame ;;;--------------------------------------------------------------------------; ;;; XPLODE.LSP ;;; Copyright 1990, 1992, 1994, 1996 by Autodesk, Inc. ;;; ;;; 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 supporting ;;; documentation. ;;; ;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS. ;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF ;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC. ;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE ;;; UNINTERRUPTED OR ERROR FREE. ;;; ;;; Use, duplication, or disclosure by the U.S. Government is subject to ;;; restrictions set forth in FAR 52.227-19 (Commercial Computer ;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii) ;;; (Rights in Technical Data and Computer Software), as applicable. ;;; --------------------------------------------------------------------------; ;;; DESCRIPTION ;;; ;;; ;;; This is a replacement for the EXPLODE command in AutoCAD. It allows ;;; you to control all of the properties of the component entities of a ;;; block or set of blocks while exploding them. There are several major ;;; differences between XPlode and the EXPLODE command in AutoCAD. ;;; ;;; First, you can select as many entities as you wish; all dimensions, ;;; polyline and polymeshes, and block insertions will be extracted from ;;; your selection set, and you will be asked to XPlode them either ;;; globally or individually. If you chose to explode them globally, you ;;; will see the following prompt for all of the candidate entities: ;;; ;;; All/Color/LAyer/LType/Inherit from parent block/: ;;; ;;; If, on the other hand, you elect to operate on each element of the ;;; selection set individually, you will need to make a selection from this ;;; prompt for each entity to be exploded. ;;; ;;; Second, the EXPLODE command in AutoCAD does not allow you to specify ;;; any of the properties for the resulting entities generated from the ;;; EXPLODE command. Nor does it allow you to let the component entities ;;; inherit the attributes of the parent block. ;;; ;;; Third, this routine allows blocks inserted with equal absolute scale ;;; factors but differing signs to be exploded (i.e. -1,1,1). This allows ;;; mirrored blocks to be exploded. ;;; ;;; ALL ;;; ;;; This option allows you to specify a color, linetype, and layer for the ;;; new entities. ;;; ;;; COLOR ;;; ;;; This option prompts you for a new color for the component entities. ;;; ;;; New color for exploded entities. ;;; Red/Yellow/Green/Cyan/Blue/Magenta/White/BYLayer/BYBlock/: ;;; ;;; You may enter any color number from 1 through 255, or one of the ;;; standard color names listed. "Cecolor" is the current entity color ;;; from the CECOLOR system variable. ;;; ;;; LAYER ;;; ;;; This option prompts you to enter the name of the layer on which you ;;; want the component entities to be placed. ;;; ;;; XPlode onto what layer? : ;;; ;;; The layer name entered is verified and if it does not exist you are ;;; reprompted for a layer name. Pressing RETURN causes the current ;;; layer to be used. ;;; ;;; LTYPE ;;; ;;; This option lists all of the loaded linetypes in the current drawing, ;;; and prompts you to choose one of them. You must type the entire ;;; linetype name (sorry), or you may press RETURN to use the current one. ;;; ;;; Choose from the following list of linetypes. ;;; CONTinuous/...others.../: ;;; ;;; INHERIT ;;; ;;; Inherit from parent block means that the attributes of the block ;;; being XPloded will be the attributes of component entities. No other ;;; choices are required. ;;; ;;; EXPLODE ;;; ;;; This option issues the current EXPLODE command for each of the entities ;;; in the selection set. ;;; ;;; --------------------------------------------------------------------------; ;;; ------------------------ INTERNAL ERROR HANDLER --------------------------; (defun xp_err (s) ; If an error (such as CTRL-C) occurs ;; while this command is active... (if (/= s "¡Lc1/4A3Q¡Lu(r)o") (princ (strcat "\n?u?~: " s)) ) (if xp_oce (setvar "cmdecho" xp_oce)) ; restore old cmdecho value (setq *error* olderr) ; restore old *error* handler (princ) ) ;;; ---------------------------- COMMON FUNCTION -----------------------------; (defun xp_val (n e f) (if f ; if f then e is an entity list. (cdr (assoc n e)) (cdr (assoc n (entget e))) ) ) ;;; ------------------------- GET ENTITY TO EXPLODE --------------------------; ;;; ---------------------------- MAIN PROGRAM --------------------------------; (defun explode ( / oce ohl e0 en e1 s0) (setq xp_oer *error* *error* xp_err) (setq xp_oce (getvar "cmdecho")) ; save value of cmdecho (setvar "cmdecho" 0) ; turn cmdecho off (graphscr) ; (princ "\n?i¡Lu-n?£g?}aoa?¢Do. ") (if (= gate "firstpass") (progn (princ " = ") (princ feed1) (princ " x ") (princ feed2) (setq gate "alreadybeenthroughonce") ) ;end of progn ) ;end of if (setq ss (ssget "w" feed1 feed2)) (if ss (progn ;; Sort out any entities not explodeable... (setq ss (xp_sxe)) ; DLine_Sort_Xplodable_Entities ;; XPlode Individually or Globally? (if (> (sslength ss) 0) (progn (if (> (sslength ss) 1) ; (progn ; (initget "Individually Globally") ; (setq ans (getkword "\n\n-O¡±O(I)/<3/4aAe(G)> ?£g?}: ")) ; ) (setq ans "Globally") ) (cond ((= ans "Individually") (setq sslen (sslength ss) j 0 ) (while (< j sslen) (setq temp (ssname ss j) prmpt T ) (redraw temp 3) (setq typ (xp_gxt)) (xp_xpe temp typ) (redraw temp 4) (setq j (1+ j)) ) ) (T (setq sslen (sslength ss) j 0 ans "Globally" prmpt T ) (setq typ (xp_gxt)) (while (< j sslen) (setq temp (ssname ss j)) (xp_xpe temp typ) (setq j (1+ j)) ) ) ) ) ) ) ) (if xp_oce (setvar "cmdecho" xp_oce)) ; restore old cmdecho value (setq *error* xp_err) ; restore old *error* handler (prin1) ) ;;; ;;; Sort out all of the entities which can be exploded from the selection ;;; set. Also ensure that block insertions have equal X, Y and Z scale factors. ;;; ;;; xp_sxe == DLine_Sort_Xplodable_Entities ;;; (defun xp_sxe (/ temp bad) (setq sslen (sslength ss) j 0 ss1 (ssadd) ) (while (< j sslen) (setq temp (ssname ss j)) (setq j (1+ j)) (if (member (xp_val 0 temp nil) '("DIMENSION" "POLYLINE" "MLINE" "LWPOLYLINE" "3DSOLID" "REGION" "BODY")) (ssadd temp ss1) (progn ;; If it is an INSERT but not a MINSERT or XREF, add it. (if (member (xp_val 0 temp nil) '("INSERT")) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "block" (cdr (assoc 2 (entget temp)))))))) ) ( (< 1 (cdr (assoc 70 (entget temp)))) ) ( (< 1 (cdr (assoc 71 (entget temp)))) ) ( T (ssadd temp ss1)) ) ) ) ) ) (setq sslen (sslength ss) bad (sslength ss1) ) ; (princ "\n") ;(princ sslen) ;(princ " -Oa?¢Do3Q¡±a¡Li. ") (if (> (- sslen bad) 0) (progn ; (princ (- sslen bad)) ; (princ " -O?O£gL(r)Aao. ") ) ) ss1 ) ;;; ;;; Set the type of explode to do. ;;; ;;; xp_gxt == XPlode_Get_Xplode_Type ;;; (defun xp_gxt (/ temp) (initget "All Color LAyer LType Inherit Explode") ; (setq temp (getkword ; "\n\n¢Dt3!(A)/AC|a(C)/1I1/4h(LA)/1/2u??(LT)/A~(c)O|U?¡Ò¡Lt1I?o(I)/: ")) ; ; (if (or (= temp "") (null temp)) (setq temp "Explode") ; ) temp ) ;;; ;;; Do the explosion of an entity. ;;; ;;; xp_xpe == XPlode_XPlode_Entity ;;; (defun xp_xpe (ent typ / ) (cond ((= typ "All") (if prmpt (progn (setq color (xp_scn)) (setq ltype (xp_slt)) (setq layer (xp_sla)) (setq prmpt nil) ) ) (xp_xfa) (if (or (= ans "Individually") (= j (1- sslen))) (progn (if (and (> sslen 1) (= ans "Globally")) (princ "\na?¢Do") (princ "\na?¢Do") ) (princ (strcat "3Q?£g?}?aaoAC|a?¢X" (if (= (type color) 'INT) (itoa color) (en_loc_type color)) ", " "1/2u??" (en_loc_type ltype) ", " "?P1I1/4h" layer ".")) ) ) ) ((= typ "Color") (if prmpt (progn (setq color (xp_scn)) (setq ltype (getvar "celtype")) (setq layer (getvar "clayer")) (setq prmpt nil) ) ) (xp_xfa) (if (or (= ans "Individually") (= j (1- sslen))) (progn (if (and (> sslen 1) (= ans "Globally")) (princ "\na?¢Do ") (princ "\na?¢Do ") ) (princ (strcat "3Q?£g?}?aaoAC|a?¢X " (if (= (type color) 'INT) (itoa color) color) ".")) ) ) ) ((= typ "LAyer") (if prmpt (progn (setq color (getvar "cecolor")) (setq ltype (getvar "celtype")) (setq layer (xp_sla)) (setq prmpt nil) ) ) (xp_xfa) (if (or (= ans "Individually") (= j (1- sslen))) (progn (if (and (> sslen 1) (= ans "Globally")) (princ "\na?¢Do ") (princ "\na?¢Do ") ) (princ (strcat "3Q?£g?}¡Li1I1/4h " layer ".")) ) ) ) ((= typ "LType") (if prmpt (progn (setq color (getvar "cecolor")) (setq ltype (xp_slt)) (setq layer (getvar "clayer")) (setq prmpt nil) ) ) (xp_xfa) (if (or (= ans "Individually") (= j (1- sslen))) (progn (if (and (> sslen 1) (= ans "Globally")) (princ "\na?¢Do ") (princ "\na?¢Do ") ) ; localization fix (princ (strcat "3Q?£g?}?aao1/2u???¢X " (en_loc_type ltype) ".")) ) ) ) ((= typ "Inherit") (xp_iap ent) ) (T (command "_.EXPLODE" (xp_val -1 ent nil)) ; explode ) ) ) ;;; ;;; Force the color, linetype and layer attributes after exploding. ;;; ;;; xp_xea == XPlode_Xplode_Force_All ;;; (defun xp_xfa () (setq e0 (entlast)) (setq en (entnext e0)) (while (not (null en)) ; find the last entity (setq e0 en) (setq en (entnext e0)) ) (command "_.EXPLODE" (xp_val -1 ent nil)) ; explode (setq s0 (ssadd)) (while (entnext e0) (ssadd (setq e0 (entnext e0)) s0 ) ) (command "_.CHPROP" s0 "" ; change entities to the proper layer "_C" color ; color, and linetype, regardless "_LT" ltype ; of their extrusion direction "_LA" layer "" ) ) ;;; ;;; Inherit attributes (if BYBLOCK) from parent. ;;; ;;; xp_iap == XPlode_Inherit_Attributes_from_Parent ;;; (defun xp_iap (t1 / t1cl t1lt t1ly s0ly s0lt s0cl t0e) (setq yyy t1) (setq t0 (entlast)) (setq tn (entnext t0)) (while (not (null tn)) ; find the last entity (setq t0 tn) (setq tn (entnext t0)) ) (setq t1cl (xp_val 62 t1 nil)) ; record the attributes of the block (setq t1lt (xp_val 6 t1 nil)) (setq t1ly (xp_val 8 t1 nil)) (command "_.EXPLODE" (xp_val -1 ent nil)) ; explode (setq s0ly (ssadd)) ; create nil selection sets for layer (setq s0lt (ssadd)) ; linetype and color changes (setq s0cl (ssadd)) (setq t0 (entnext t0)) (while t0 ; can exploded entities (setq t0e (entget t0)) ; and build selection sets (if (= (xp_val 62 t0e T) "BYBLOCK") (ssadd t0 s0cl)) (if (= (xp_val 6 t0e T) "BYBLOCK") (ssadd t0 s0lt)) (if (= (xp_val 8 t0e T) "0") (ssadd t0 s0ly)) (setq t0 (entnext t0)) ) (if (> (sslength s0cl) 0) ; is selection set non-nil... (command "_.CHPROP" s0cl "" ; Change exploded entities with color "_CO" t1cl "") ; BYBLOCK to color of old block ) (if (> (sslength s0lt) 0) (command "_.CHPROP" s0lt "" ; Change exploded entities with linetype "_LT" t1lt "") ; BYBLOCK to linetype of old block ) (if (> (sslength s0ly) 0) (command "_.CHPROP" s0ly "" ; Change exploded entities with linetype "_LA" t1ly "") ; BYBLOCK to linetype of old block ) (if (or (= ans "Individually") (= j (1- sslen))) (progn (if (and (> sslen 1) (= ans "Globally")) (princ "\na?¢Do ") (princ "\na?¢Do ") ) (princ "3Q?£g?}.") ) ) ) ;;; ;;; Set the color for the exploded entities. ;;; ;;; xp_scn == XPlode_Set_Color_Number ;;; (defun xp_scn () (setq arg 257) (while (> arg 256) (initget 2 "Red Yellow Green Cyan Blue Magenta White BYLayer BYBlock") (setq arg (getint (strcat "\n\n?£g?}?aa?¢Doao¡PsAC|a." "\n?o(R)/?A(Y)/on(G)/?C(C)/AA(B)/£g£g?o(M)/¢DO(W)/ByLayer(BYL)/ ByBlock(BYB) <" (if (= (type (getvar "cecolor")) 'INT) (itoa (getvar "cecolor")) (en_loc_type (getvar "cecolor")) ;display the translated term ) ">: "))) (cond ((= arg "BYBlock") (setq arg 0)) ((= arg "Red") (setq arg 1)) ((= arg "Yellow") (setq arg 2)) ((= arg "Green") (setq arg 3)) ((= arg "Cyan") (setq arg 4)) ((= arg "Blue") (setq arg 5)) ((= arg "Magenta") (setq arg 6)) ((= arg "White") (setq arg 7)) ((= arg "BYLayer") (setq arg 256)) (T (if (= (type arg) 'INT) (if (> arg 255) (progn (princ "\nAC|a¡M11/2X?W¢DX 1 - 255 ao1/2d3o. ") (setq arg 257) ; kludge ) ) (setq arg (if (= (type (setq arg (getvar "cecolor"))) 'INT) (getvar "cecolor") (cond ((= arg "BYBLOCK") (setq arg 0)) ((= arg "BYLAYER") (setq arg 256)) ) ) ) ) ) ) ) (cond ((= arg 0) (setq arg "BYBLOCK")) ((= arg 256) (setq arg "BYLAYER")) ) arg ) ;;; ;;; Set the linetype from the loaded linetypes. ;;; ;;; xp_slt == XPlode_Set_Line_Type ;;; (defun xp_slt (/ temp) (while (null temp) (initget 1) (setq temp (strcase (getstring (strcat "\n?e?J*sao1/2u??|WoU. <" (en_loc_type(getvar "celtype")) "> : ") ))) ; Strip the underscore away (if (equal "_" (substr temp 1 1)) (setq temp (substr temp 2))) (if (or (= temp "") (null temp)) (setq temp (en_loc_type (getvar "celtype"))) (if (not (or (tblsearch "ltype" (loc_en_type temp)) (= temp "BYBLOCK") (= temp "BYLAYER") (= temp "CONTINUOUS") )) (progn (princ "\n£gL(r)Aao1/2u??|WoU.") (setq temp nil) ) ) ) ) temp ) ;;; ;;; Set a layer if it exists. ;;; ;;; xp_sla == XPlode_Set_LAyer ;;; (defun xp_sla (/ temp) (while (null temp) (initget 1) (setq temp (getstring (strcat "\n\n?£g?}¡Li-t-O1I1/4h? <" (getvar "clayer") ">: "))) (if (or (= temp "") (null temp)) (setq temp (getvar "clayer")) (if (not (tblsearch "layer" temp)) (progn (princ "\n£gL(r)Aao1I1/4h|WoU. ") (setq temp nil) ) ) ) ) temp ) ;; Localization fix ;; the function returns the translated and UPPERCASED name ;; (defun en_loc_type (type / trans) (setq trans type) (if (= (strcase trans) "BYLAYER") (setq trans (strcase "BYLayer")) (if (= (strcase trans) "BYBLOCK") (setq trans (strcase "BYBlock"))) ) trans ) ;; Localization fix ;; The function returns the english no localized term ;; (defun loc_en_type (type / trans ) (setq trans type) (if (= (strcase type) (strcase "BYLayer")) (setq trans "BYLAYER") (if (= (strcase type) (strcase "BYBlock")) (setq trans "BYBLOCK") ) ) trans ) ;;; --------------------------------------------------------------------------; (defun c:xxp () (explode)) (defun c:xxplode () (explode)) (princ "\nC:XPlode ?w¡Mg3Q¡Mu?J.") (princ)