Transfert d\'attributs entre blocs

[Invité Patrick]

Une suggestion de développement: transférer les valeurs des attributs d'un bloc sur un autre bloc. (merci MatSoYa pour l'idée!)

[Patrick_35]

Un lisp que j'ai fait il y a un petit moment (fonction CAT)

 

;;;=================================================================

;;;

;;; CAT.LSP V1.10

;;;

;;; Copier des attributs

;;;

;;; Copyright ©

;;;

;;;=================================================================

 

(defun c:cat(/ chemin cmd fichier nom_bloc s)

 

;;;---------------------------------------------------------------

;;;

;;; Gestion des erreurs

;;;

;;;---------------------------------------------------------------

 

(defun *errcat* (msg)

(if (/= msg "Function cancelled")

(if (= msg "quit / exit abort")

(princ)

(princ (strcat "\nErreur : " msg))

)

(princ)

)

(setq *error* s)

(setvar "cmdecho" cmd)

(princ)

)

 

;;;---------------------------------------------------------------

;;;

;;; Routine principale

;;;

;;;---------------------------------------------------------------

 

(defun changer_texte_attributs(/ a b c n p r s ttt u v)

 

;;;-------------------------------------------------------------

;;;

;;; Changement de texte de l'entité

;;;

;;;-------------------------------------------------------------

 

(setq p (getvar "pickadd"))

(setvar "pickadd" 0)

(princ "\nSélectionner le Bloc de Référence.")

(setq s (ssget))

(setvar "pickadd" 1)

(if (/= s nil)

(progn

(setq r (entget (ssname s 0)))

(if (= (cdr (assoc 0 r)) "INSERT")

(progn

(if (= (cdr (assoc 66 r)) 1)

(progn

(princ "\nSélection des Blocs à Mofifier.")

(setq s (ssget))

(setvar "pickadd" p)

(if (/= s nil)

(progn

(setq n 0)

(setq u 0)

(while (/= (ssname s n) nil)

(setq a r)

(setq v 0)

(setq b (entget (ssname s n)))

(if (= (cdr (assoc 0 b)) "INSERT")

(setq ttt 1)

)

(if (and (/= (cdr (assoc -1 a)) (cdr (assoc -1 b))) (= (cdr (assoc 2 a)) (cdr (assoc 2 b))))

(progn

(while (and (/= (cdr (assoc 0 a)) "SEQEND") (/= (cdr (assoc 0 b)) "SEQEND"))

(setq c (subst (assoc 1 a) (assoc 1 b) b))

(entmod c)

(setq a (entget (entnext (cdr (assoc -1 a)))))

(setq b (entget (entnext (cdr (assoc -1 b)))))

(setq v 1)

)

(if (/= v 0)

(progn

(entupd (cdr (assoc -1 (entget (ssname s n)))))

(setq u (1+ u))

)

)

)

)

(setq n (1+ n))

)

(if (and (= ttt 1) (= u 0))

(alert "Pas de blocs correspondant au bloc de référence.")

)

(if (= ttt nil)

(alert "Pas de blocs sélectionnés.")

)

(if (/= u 0)

(princ (strcat "\n" (itoa u) " blocs modifiés..."))

)

)

)

)

(alert "Bloc sans Attributs")

)

)

(alert "Pas de Bloc Sélectionné...")

)

)

(princ "\nAucune Sélection...")

)

)

 

;;;---------------------------------------------------------------

;;;

;;; Routine de lancement

;;;

;;;---------------------------------------------------------------

 

(setq s *error*)

(setq *error* *errcat*)

(setq cmd (getvar "cmdecho"))

(setvar "cmdecho" 0)

(command "_.undo" "_group")

(changer_texte_attributs)

(command "_.undo" "_end")

(setq *error* s)

(setvar "cmdecho" cmd)

(princ)

)

 

(setq nom_lisp "CAT")

(if (/= app nil)

(if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)

(princ (strcat "..." nom_lisp " chargé."))

(princ (strcat "\n" nom_lisp ".LSP Chargé.....Tapez " nom_lisp " pour l'éxecuter.")))

(princ (strcat "\n" nom_lisp ".LSP Chargé......Tapez " nom_lisp " pour l'éxecuter.")))

(setq nom_lisp nil)

(princ)