home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p030 / 2.ddi / ATTREDEF.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-08-10  |  8.4 KB  |  256 lines
  1. ; *******************************************************************
  2. ;                          ATTREDEF.LSP
  3. ;
  4. ; This program allows you to redefine a Block and update the
  5. ; Attributes associated with any previous insertions of that Block.
  6. ; All new Attributes are added to the old Blocks and given their
  7. ; default values. All old Attributes with equal tag values to the new
  8. ; Attributes are redefined but retain their old value. And all old
  9. ; Attributes not included in the new Block are deleted.
  10. ;
  11. ; Note that if handles are enabled, new handles will be assigned to
  12. ; each redefined block.
  13. ;
  14. ; Written by Karry Layden - May 1988
  15. ; *******************************************************************
  16.  
  17.  
  18. ; Oldatts sets "old" to the list of old Attributes for each Block.
  19. ; The list does not include constant Attributes.
  20.  
  21. (defun oldatts (/ an e)
  22.    (setq an (entnext b1))
  23.    (setq e (entget an))
  24.    (while (and (= (cdr (assoc 0 e)) "ATTRIB")
  25.                (member (cdr (assoc 70 e)) '(0 1 4 5 8 9 12 13)))
  26.       (if old
  27.          (setq old (cons e old))
  28.          (setq old (list e))
  29.       )
  30.       (setq an (entnext an))
  31.       (if an
  32.          (setq e (entget an))
  33.       )
  34.       (setq count (1+ count))         ; count the number of old atts
  35.    )
  36. )
  37.  
  38. ; Newatts sets "new" to the list of new Attributes in the new Block.
  39. ; The list does not include constant Attributes.
  40.  
  41. (defun newatts (ssetn l / i an e)
  42.    (setq i 0)
  43.    (while (<= i l)
  44.       (setq an (ssname ssetn i))
  45.       (setq e (entget an))
  46.       (if (and (= (cdr (assoc 0 e)) "ATTDEF")
  47.                (member (cdr (assoc 70 e)) '(0 1 4 5 8 9 12 13)))
  48.             (progn
  49.                (if new
  50.                   (setq new (cons e new))
  51.                   (setq new (list e))
  52.                )
  53.                (setq n (1+ n))        ; count the number of new atts
  54.             )
  55.       )
  56.       (setq i (1+ i))
  57.    )
  58. )
  59.  
  60. ; Compare the list of "old" to the list of "new" Attributes and make
  61. ; the two lists "same" and "preset". "Same" contains the old values of
  62. ; all the Attributes in "old" with equal tag values to some Attribute
  63. ; in "new" and the default values of all the other Attributes. "Preset"
  64. ; contains the preset Attributes in old with equal tag values to some
  65. ; Attribute in new.
  66.  
  67. (defun compare (/ i j)
  68.    (setq i 0
  69.          j 0
  70.          eds 0
  71.          same nil
  72.          amount 0
  73.          preset nil)
  74.    (while (<= i (1- n))
  75.       (cond ((= (cdr (assoc 2 (nth j old))) (cdr (assoc 2 (nth i new))))
  76.                 (if (member (cdr (assoc 70 (nth i new))) '(8 9 12 13))
  77.                    (progn
  78.                       (if preset
  79.                          (setq preset (cons (nth j old) preset))
  80.                          (setq preset (list (nth j old)))
  81.                       )
  82.                       (setq eds (1+ eds)) ; count equal preset atts
  83.                    )
  84.                    (if same
  85.                       (setq same (cons (cdr (assoc 1 (nth j old))) same))
  86.                       (setq same (list (cdr (assoc 1 (nth j old)))))
  87.                    )
  88.                 )
  89.                 (if (member (cdr (assoc 70 (nth i new))) '(4 5))
  90.                    (setq amount (+ 1 amount))
  91.                 )
  92.                 (setq i (1+ i))
  93.                 (setq j 0)
  94.              )
  95.              ((= j (1- count))
  96.                 (if (not (member (cdr (assoc 70 (nth i new))) '(8 9 12 13)))
  97.                    (if same
  98.                       (setq same (cons (cdr (assoc 1 (nth i new))) same))
  99.                       (setq same (list (cdr (assoc 1 (nth i new)))))
  100.                    )
  101.                 )
  102.                 (if (member (cdr (assoc 70 (nth i new))) '(4 5))
  103.                    (setq amount (+ 1 amount))
  104.                 )
  105.                 (setq i (1+ i))
  106.                 (setq j 0)
  107.              )
  108.              (t
  109.                 (setq j (1+ j))
  110.              )
  111.       )
  112.    )
  113. )
  114.  
  115. ; Find the entity for each of the "preset" Attributes in the newly
  116. ; inserted Block.
  117.  
  118. (defun findpt ()
  119.    (setq test T)
  120.    (setq en (entnext e1))
  121.    (setq e (entget en))
  122.    (while test
  123.       (if (and (= (cdr (assoc 0 e)) "ATTRIB") (= (cdr (assoc 2 e)) tag))
  124.          (setq test nil)
  125.          (progn
  126.             (setq ex en)
  127.             (setq en (entnext ex))
  128.             (if e
  129.                (setq e (entget en))
  130.             )
  131.          )
  132.       )
  133.    )
  134. )
  135.  
  136. ; Insert a new Block on top of each old Block and set its new Attributes
  137. ; to their values in the list "same". Then replace each of the "preset"
  138. ; Attributes with its old value.
  139.  
  140. (defun redef (/ xsf ysf zsf ls i e1 v)
  141.    (command "ucs" "e" b1)             ; define the block's UCS
  142.    (setq xsf (cdr (assoc 41 (entget b1)))) ; find x scale factor
  143.    (setq ysf (cdr (assoc 42 (entget b1)))) ; find y scale factor
  144.    (setq zsf (cdr (assoc 43 (entget b1)))) ; find z scale factor
  145.    (setq ls (1- (length same)))
  146.    (setq i 0)
  147.    (command "insert" bn "0.0,0.0,0.0" "XYZ" xsf ysf zsf "0.0")
  148.    (while (<= i ls)                   ; set attributes to their values
  149.       (command (nth i same))
  150.       (setq i (1+ i))
  151.    )
  152.    (while (< 0 amount)
  153.       (command "")                    ; at prompts, verify attributes
  154.       (setq amount (1- amount))
  155.    )
  156.    (setq i 0)
  157.    (setq e1 (entlast))
  158.    (while (< 0 eds)                   ; edit each of the "preset" attributes
  159.       (setq tag (cdr (assoc 2 (nth i preset))))
  160.       (setq v (cdr (assoc 1 (nth i preset))))
  161.       (findpt)                        ; find the entity to modify
  162.       (setq e (subst (cons 1 v) (assoc 1 e) e))
  163.       (entmod e)                      ; modify the entity's value
  164.       (setq i (1+ i))
  165.       (setq eds (1- eds))
  166.    )
  167.    (command "ucs" "p")                ; restore the previous UCS
  168. )
  169.  
  170. ; System variable save
  171.  
  172. (defun modes (a)
  173.    (setq mlst '())
  174.    (repeat (length a)
  175.       (setq mlst (append mlst (list (list (car a) (getvar (car a))))))
  176.       (setq a (cdr a)))
  177. )
  178.  
  179. ; System variable restore
  180.  
  181. (defun moder ()
  182.    (repeat (length mlst)
  183.       (setvar (caar mlst) (cadar mlst))
  184.       (setq mlst (cdr mlst))
  185.    )
  186. )
  187.  
  188. ; Internal error handler
  189.  
  190. (defun attrerr (s)                    ; If an error (such as CTRL-C) occurs
  191.                                       ; while this command is active...
  192.    (if (/= s "Function cancelled")
  193.       (princ (strcat "\nError: " s))
  194.    )
  195.    (moder)                            ; restore saved modes
  196.    (setq *error* olderr)              ; restore old *error* handler
  197.    (princ)
  198. )
  199.  
  200. ; Main program
  201.  
  202. (defun C:ATTREDEF (/ k n olderr bn sseto ssetn pt l new
  203.                      old same presets b1 count amount)
  204.    (setq k 0
  205.          n 0
  206.          test T
  207.          olderr *error*
  208.          *error* attrerr)
  209.  
  210.    (modes '("CMDECHO" "ATTDIA" "ATTREQ" "GRIDMODE" "UCSFOLLOW"))
  211.    (setvar "cmdecho" 0)               ; turn cmdecho off
  212.    (setvar "attdia" 0)                ; turn attdia off
  213.    (setvar "attreq" 1)                ; turn attreq on
  214.    (setvar "gridmode" 0)              ; turn gridmode off
  215.    (setvar "ucsfollow" 0)             ; turn ucsfollow off
  216.  
  217.    (while test
  218.       (setq bn (strcase (getstring "\nName of Block you wish to redefine: ")))
  219.       (if (null (setq sseto (ssget "X" (list (cons 2 bn)))))
  220.          (progn
  221.             (princ "\nBlock ")
  222.             (princ bn)
  223.             (princ " is not defined. Please try again.")
  224.          )
  225.          (setq test nil)
  226.       )
  227.    )
  228.    (setq test T)
  229.    (while test
  230.       (princ "\nSelect new Block... ")
  231.       (if (null (setq ssetn (ssget)))
  232.          (princ "\nNo new Block selected. Please try again.")
  233.          (setq test nil)
  234.       )
  235.    )
  236.    (initget 17)
  237.    (setq pt (getpoint "\nInsertion base point of new Block: "))
  238.    (setq l (1- (sslength sseto)))
  239.    (newatts ssetn (1- (sslength ssetn))) ; find the list of new attributes
  240.    (command "block" bn "Y" pt ssetn "")  ; redefine the block
  241.    (while (<= k l)
  242.       (setq b1 (ssname sseto k))      ; For each old block...
  243.       (setq old nil)
  244.       (setq count 0)
  245.       (oldatts)                       ; find the list of old attributes,
  246.       (compare)                       ; compare the old list with the new,
  247.       (redef)                         ; and redefine its attributes.
  248.       (entdel b1)                     ; delete the old block.
  249.       (setq k (1+ k))
  250.    )
  251.    (moder)                            ; restore saved modes
  252.    (command "regenall")
  253.    (setq *error* olderr)              ; restore old *error* handler
  254.    (princ)
  255. )
  256.