home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / FLX_PCOP.LSP < prev    next >
Lisp/Scheme  |  1996-09-30  |  2KB  |  77 lines
  1. ;;; FLX_PCOP.LSP
  2. ;;; ==========================================================
  3. ;;; (C)opyright Felix Computer Aided Technologies GmbH 1995-96
  4. ;;; ==========================================================
  5. ;;; Created: Jan 20, 1996 / vp
  6. ;;; Changed: Sep 29, 1996 / vp
  7. ;;; ==========================================================
  8. ;;; This function "copies" the properties layer, linetype
  9. ;;; and color of a selected entity to the objects selected
  10. ;;; by the user when prompted to select objects...
  11. ;;; ==========================================================
  12.  
  13. (defun FLX_COPYPROP( / prt_list e1 e2 el1 el2 ep1 s1 s2 s3)
  14.  
  15.   ;;; Error Handler
  16.  
  17.   (FLX_FUNC_INIT)
  18.  
  19.   ;;; Prompt List
  20.   
  21.   (setq prt_list '(
  22.      "Select entity for reference properties: "
  23.      "Select objects to modify...\n"
  24.   ))
  25.   (if FLX_XLANGUAGE (FLX_XLANGUAGE "_pcop" nil))   
  26.  
  27.   ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  28.   (if (entlast) (progn
  29.     ;;;@Select entity for reference properties: 
  30.     (setq ep1 (entsel (nth 0 prt_list)))
  31.     (if ep1 (progn
  32.       (setq el1 (entget (setq e1 (car ep1))))
  33.       (setq s1 (assoc 62 el1) s2 (assoc 6 el1))
  34.       (setq s3 (assoc 8 el1))
  35.       ;;;@Select objects to modify: 
  36.       (princ (nth 1 prt_list))
  37.       (setq ss1 (ssget))
  38.       (if ss1 
  39.          (progn
  40.             (setq i1 (sslength ss1))
  41.             (while (> i1 0)
  42.               (setq i1 (1- i1))
  43.               (setq el2 (entget (setq e2 (ssname ss1 i1))))
  44.               (if s1  ;;; COLOR
  45.                 (if (assoc 62 el2)
  46.                   (setq el2 (subst s1 (assoc 62 el2) el2))
  47.                   (setq el2 (append el2 (list s1)))
  48.                 )
  49.                 (setq el2 (append el2 (list (cons 62 256))))
  50.               )
  51.               (if s2  ;;; LINETYPE
  52.                 (if (assoc 6 el2)
  53.                   (setq el2 (subst s2 (assoc 6 el2) el2))
  54.                   (setq el2 (append el2 (list s2)))
  55.                 )
  56.                 (setq el2 (append el2 (list (cons 6 "BYLAYER"))))
  57.               )
  58.               (if s3  ;;; LAYER
  59.                 (setq el2 (subst s3 (assoc 8 el2) el2))
  60.               )
  61.              (entmod el2)
  62.              (if (or (= (cdr (assoc 0 el2)) "INSERT")
  63.                      (= (cdr (assoc 0 el2)) "POLYLINE")
  64.                  )
  65.                    (entupd e2)
  66.              )
  67.            )
  68.          ) 
  69.        )
  70.     )) ;;; if ep1
  71.   )) ;;; if entlast
  72.   (FLX_FUNC_EXIT)
  73.   (princ)
  74. )
  75.  
  76. (princ)
  77.