DECKER & CAD SOLUTIONS

Programmes Lisp -

Source du programme Ch_Bloc

(defun c:Ch_bloc(/ xattreq blocd blocs blocs2 a b c x y z x1 y1 z1 calque angle fex fey fez mode ld1 ld2 ld3 ld4 ldxyz ldangle ldcalque ldhauteur ldfacteurx ldoblique ldstyle ldmiroir ldjustificationh ldjustification ldextrusion ldjustificationv purger renommer filtre jeu ptr entite propriete)

(write-line "\nTéléchargé depuis le site Internet http://www.decker-cs.com")

(write-line "Auteur : Christian Decker")

;

(write-line "Remplacer les blocs.")

;

(setq xattreq(getvar "ATTREQ")) ;Mémorise la variable système "ATTREQ" d'Autocad.

(setvar "ATTREQ" 0)

;

;Saisie utilisateur.

;

(setq blocd(getstring t "Nom de l'ancien bloc : " )) ;Nota : les noms des blocs peuvent contenir des espaces.

(setq blocs(getstring t "Nom du nouveau bloc : " ))

;

;Attribut à la variable "blocs2" le nom du nouveau bloc sans son chemin.

;

(if (> (strlen blocs) 2) ;Le nom du bloc a une longueur supérieure à 2 caractères.

(progn

(if (= (substr blocs 2 1) ":") ;Le nom du bloc est donné avec son chemin.

(progn

(setq a(strlen blocs))

(while (> a 0) ;Extraction du nom du nouveau bloc sans son chemin.

(if (= (substr blocs a 1) "\\")

(progn

(setq blocs2(substr blocs (+ a 1) (- (strlen blocs) a)))

(setq a 0)

)

(setq a(- a 1))

)

(setq blocs2 blocs) ;Le nom du nouveau bloc est donné sans son chemin.

)

(setq blocs2 blocs) ;La longueur du nom du nouveau bloc n'est pas supérieure à 2 caractères.

)

;

;Saisie utilisateur.

;

(setq x1(getreal "Décalage en X du point d'insertion du nouveau bloc : "))

(setq y1(getreal "Décalage en Y du point d'insertion du nouveau bloc : "))

(setq z1(getreal "Décalage en Z du point d'insertion du nouveau bloc : "))

;

(while (and (/= mode "O") (/= mode "N")) ;Mise en boucle jusqu'à ce que mode est égale à O ou N.

(setq mode(getstring "Préserver les propriétés des attributs de l'ancien bloc (point d'insertion, justification, angle de rotation, hauteur, facteur largeur de texte, angle de texte oblique, style, calque, miroir et extrusion) (Oui/Non) : "))

(setq mode(strcase mode)) ;Force les caractères en majuscule.

(if (> (strlen mode) 0) ;La chaîne contient au moins un caractère.

(progn

(if (= (substr mode 1 1) "O") ;Le premier caractère correspond à la lettre O.

(setq mode "O")

)

(if (= (substr mode 1 1) "N") ;Le premier caractère correspond à la lettre N.

(setq mode "N")

)

;

(setq ld3 nil)

(setq ld4 nil)

(repeat (getint "Nombre d'étiquettes en correspondance : ")

;Nota : Les noms d'étiquettes ne peuvent pas contenir d'espaces.

(setq ld3(cons (getstring "Etiquette de l'ancien bloc : ") ld3))

(setq ld4(cons (getstring "Etiquette du nouveau bloc : ") ld4))

)

;

(while (and (/= purger "O") (/= purger "N"))

;Mise en boucle jusqu'à ce que purger est égale à la lettre O ou N.

(setq purger(getstring "Purger les anciens blocs (Oui/Non) : "))

(setq purger(strcase purger)) ;Force les caractères en majuscule.

(if (> (strlen purger) 0) ;La chaîne contient au moins un caractère.

(progn

(if (= (substr purger 1 1) "O") ;Le premier caractère correspond à la lettre O.

(progn

(setq purger "O")

(while (and (/= renommer "O") (/= renommer "N"))

;Mise en boucle jusqu'à ce que renommer est égale à la lettre O ou N.

(setq renommer(getstring "Renommer les nouveaux blocs par le nom de l'ancien bloc (Oui/Non) : "))

(setq renommer(strcase renommer)) ;Force les caractères en majuscule.

(if (> (strlen renommer) 0) ;La chaîne contient au moins un caractère.

(progn

(if (= (substr renommer 1 1) "O") ;Le premier caractère correspond à la lettre O.

(setq renommer "O")

)

(if (= (substr renommer 1 1) "N") ;Le premier caractère correspond à la lettre N.

(setq renommer "N")

)

(if (= (substr purger 1 1) "N") ;Le premier caractère correspond à la lettre N.

(setq purger "N")

)

;

;Vérification des noms de blocs.

;

(if (= blocd blocs2)

(progn ;Le nom de l'ancien bloc est identique au nouveau bloc.

(write-line "Le nom de l'ancien bloc doit être différent du nom du nouveau bloc.")

(princ)

)

(progn ;Le nom de l'ancien bloc est différent du nouveau bloc.

;

;Remplacement des anciens blocs.

;

(if (/= (tblsearch "BLOCK" blocd) nil) ;L'ancien bloc existe dans la table des définitions de blocs.

(progn

(setq filtre(list (cons '0 "INSERT") (cons '2 blocd))) ;Préparation du filtre de sélection.

(setq jeu(ssget "X" filtre)) ;Création du jeu de sélection.

(if (/= jeu nil)

(progn

;

;Il y a au moins un ancien bloc dans le dessin.

;Vérifie qu'Autocad peut trouver le nouveau bloc.

;

(if (= (tblsearch "BLOCK" blocs2) nil)

;Le nouveau bloc n'existe pas dans la table des définitions de blocs.

(progn

(command "._INSERT" blocs) ;Essaie d'insérer le nouveau bloc.

(if (/= (tblsearch "BLOCK" blocs2) nil) ;Succès de l'insertion du nouveau bloc.

(progn

(command "0,0" "" "" "") ;Insertion du bloc au coordonnées 0,0.

(entdel(entlast)) ;Déstruction du bloc inséré pour la vérification.

)

(if (/= (tblsearch "BLOCK" blocs2) nil)

;Maintenant le nouveau bloc existe dans la table des définitions de blocs.

(progn

(setq ptr 0)

(while (< ptr (sslength jeu)) ;Pour chaque ancien bloc trouvé dans le dessin...

;

;Extraction du point d'insertion du bloc.

;

(setq propriete(entget(ssname jeu ptr))) ;Obtient la liste des propriétés du bloc.

(setq x(car(cdr(assoc '10 propriete)))) ;Extrait la coordonnée X du bloc.

(setq y(car(cdr(cdr(assoc '10 propriete))))) ;Extrait la coordonnée Y du bloc.

(setq z(car(cdr(cdr(cdr(assoc '10 propriete)))))) ;Extrait la coordonnée Z du bloc.

(setq fex(cdr(assoc '41 propriete))) ;Extrait le facteur d'échelle en X du bloc.

(setq fey(cdr(assoc '42 propriete))) ;Extrait le facteur d'échelle en Y du bloc.

(setq fez(cdr(assoc '43 propriete))) ;Extrait le facteur d'échelle en Z du bloc.

(setq calque(cdr(assoc '8 propriete))) ;Extrait le calque du bloc.

(setq angle(cdr(assoc '50 propriete))) ;Extrait l'angle du bloc.

;

;Ajoute le décalage en X du point d'insertion du nouveau bloc.

;

(if (/= x1 0)

(progn

(if (> x1 0)

(setq x(+ x x1))

(setq x(- x (abs x1)))

)

;

;Ajoute le décalage en Y au point d'insertion du nouveau bloc.

;

(if (/= y1 0)

(progn

(if (> y1 0)

(setq y(+ y y1))

(setq y(- y (abs y1)))

)

;

;Ajoute le décalage en Z au point d'insertion du nouveau bloc.

;

(if (/= z1 0)

(progn

(if (> z1 0)

(setq z(+ z z1))

(setq z(- z (abs z1)))

)

;

;Initialisation des listes de données.

;

(setq a(list x y z)) ;Mémorise les coordonnées de l'ancien bloc.

(setq ld1 nil) ;Vide la liste des étiquettes de l'ancien bloc.

(setq ld2 nil) ;Vide la liste des valeurs d'attributs de l'ancien bloc.

(setq ldxyz nil) ;Vide la liste des points d'insertion des attributs de l'ancien bloc.

(setq ldangle nil) ;Vide la liste des angles de rotation des attributs de l'ancien bloc.

(setq ldcalque nil) ;Vide la liste des calques des attributs de l'ancien bloc.

(setq ldhauteur nil) ;Vide la liste des hauteurs de textes des attributs de l'ancien bloc.

(setq ldoblique nil) ;Vide la liste des angles de textes obliques des attributs de l'ancien bloc.

(setq ldstyle nil) ;Vide la liste des styles de textes des attributs de l'ancien bloc.

(setq ldjustificationh nil) ;Vide la liste des justifications horizontales des attributs de l'ancien bloc (0 = Gauche; 1 = Centre; 2 = Droite; 3 = Aligné; 4 = Milieu; 5 = Fixé).

(setq ldjustificationv nil) ;Vide la liste des justifications verticales des attributs de l'ancien bloc (0 = texte justifié à gauche; 1 = Bas; 2 = Milieu 3 = Haut).

(setq ldjustification nil) ;Vide la liste des coordonnées correspondant à la justification de texte des attributs de l'ancien bloc (les coordonnées sont différentes de 0 lorsque la justification du texte n'est pas égale à Gauche).

(setq ldfacteurx nil) ;Vide la liste des facteurs X des attributs de l'ancien bloc (facteur de la largeur du texte).

(setq ldmiroir nil) ;Vide la liste des valeurs de l'effet miroir des attributs de l'ancien bloc (0 = pas de miroir; 2 = miroir en X; 4 = miroir en Y).

(setq ldextrusion nil) ;Vide la liste des directions d'extrusion des attributs de l'ancien bloc.

;

;Mémorisation des étiquettes, des valeurs et des points d'insertion des attributs de l'ancien bloc.

;

(setq entite(entnext(ssname jeu ptr))) ;Cible l'ancien bloc à remplacer.

(while (and (/= entite nil) (/= (cdr(assoc '0 (entget entite))) "SEQEND"))

;Pour chaque étiquette de l'ancien bloc...

(setq propriete(entget entite)) ;Obtient la liste des propriétés de l'attribut.

(setq ld1(cons (cdr(assoc '2 propriete)) ld1)) ;Extrait l'étiquette.

(setq ld2(cons (cdr(assoc '1 propriete)) ld2)) ;Extrait la valeur de l'attribut.

(if (= mode "O")

(progn

(setq ldxyz(cons (cdr(assoc '10 propriete)) ldxyz)) ;Extrait les coordonnées de l'attribut.

(setq ldangle(cons (cdr(assoc '50 propriete)) ldangle)) ;Extrait l'angle de rotation de l'attribut.

(setq ldcalque(cons (cdr(assoc '8 propriete)) ldcalque)) ;Extrait le calque de l'attribut.

(setq ldhauteur(cons (cdr(assoc '40 propriete)) ldhauteur)) ;Extrait la hauteur de texte de l'attribut.

(setq ldoblique(cons (cdr(assoc '51 propriete)) ldoblique)) ;Extrait l'angle de texte oblique de l'attribut.

(setq ldstyle(cons (cdr(assoc '7 propriete)) ldstyle)) ;Extrait le style de texte de l'attribut.

(setq ldjustificationh(cons (cdr(assoc '72 propriete)) ldjustificationh)) ;Extrait la justification horizontale de l'attribut.

(setq ldjustificationv(cons (cdr(assoc '73 propriete)) ldjustificationv)) ;Extrait la justification verticale de l'attribut.

(setq ldjustification(cons (cdr(assoc '11 propriete)) ldjustification)) ;Extrait les coordonnées correspondant à la justification du texte de l'attribut.

(setq ldfacteurx(cons (cdr(assoc '41 propriete)) ldfacteurx)) ;Extrait le facteur X de l'attribut (facteur de la largeur du texte).

(setq ldmiroir(cons (cdr(assoc '71 propriete)) ldmiroir)) ;Extrait l'effet miroir de l'attribut.

(setq ldextrusion(cons (cdr(assoc '210 propriete)) ldextrusion)) ;Extrait la direction d'extrusion de l'attribut.

)

(setq entite(entnext entite))

)

;

;Insertion du nouveau bloc.

;

(command "._INSERT" blocs a "" "" "") ;Nota : Le point d'insertion peut être aproximatif (doit toujours être mise à jour au niveau propriete).

(setq entite(entlast)) ;Sélectionne le nouveau bloc inséré.

(setq propriete(entget entite)) ;Obtient la liste des propriétés du nouveau bloc.

(setq propriete(subst (cons '10 a) (assoc '10 propriete) propriete)) ;Affecte les coordonnées de l'ancien bloc.

(setq propriete(subst (cons '41 fex) (assoc '41 propriete) propriete)) ;Affecte le facteur d'échelle en X de l'ancien bloc.

(setq propriete(subst (cons '42 fey) (assoc '42 propriete) propriete)) ;Affecte le facteur d'échelle en Y de l'ancien bloc.

(setq propriete(subst (cons '43 fez) (assoc '43 propriete) propriete)) ;Affecte le facteur d'échelle en Z de l'ancien bloc.

(setq propriete(subst (cons '8 calque) (assoc '8 propriete) propriete)) ;Affecte le calque de l'ancien bloc.

(setq propriete(subst (cons '50 angle) (assoc '50 propriete) propriete)) ;Affecte l'angle de l'ancien bloc.

(entmod propriete)

(entupd entite)

(if (> (length ld1) 0) ;L'ancien bloc a des attributs.

(progn

(setq entite(entnext(entlast))) ;Sélectionne le 1er attribut du nouveau bloc inséré (s'il y a au moins un attribut).

(while (and (/= entite nil) (/= (cdr(assoc '0 (entget entite))) "SEQEND")) ;Pour chaque attribut du nouveau bloc...

(setq propriete(entget entite)) ;Obtient la liste des propriétés de l'attribut.

(if (and (> (length ld3) 0) (> (length ld4) 0) (= (length ld3) (length ld4)))

(progn

;

;Il y a des étiquettes en correspondance.

;Vérifie si l'étiquette du nouveau bloc est en correspondance avec une étiquette

;de l'ancien bloc.

;

(setq a 0)

(setq b nil)

(while (and (> (length ld4) a) (= b nil)) ;Scrute la liste des étiquettes en correspondance de l'ancien bloc.

(if (= (strcase (nth a ld4)) (strcase (cdr(assoc '2 propriete)))) ;L'étiquette existe dans la liste (comparaison forcée en majuscules).

(setq b(nth a ld3)) ;Attribue à la variable "b" le nom de l'étiquette de l'ancien bloc, correspondant au nom de l'étiquette du nouveau bloc.

)

(setq a(+ a 1))

)

(if (/= b nil)

(progn

;

;L'étiquette du nouveau bloc est en correspondance avec une étiquette de l'ancien bloc.

;

(setq a 0)

(setq c 0)

(while (and (> (length ld1) a) (= c 0)) ;Tant que l'étiquette correspondante n'est pas localisée dans la liste des étiquettes de l'ancien bloc.

(if (= (strcase (nth a ld1)) (strcase b)) ;L'étiquette correspondante est localisée dans la liste des étiquettes de l'ancien bloc (comparaison forcée en majuscules).

(progn

(setq propriete(subst(cons '1 (nth a ld2)) (assoc '1 propriete) propriete)) ;Affecte la valeur contenue dans l'attribut correspondant de l'ancien bloc.

(if (= mode "O") ;Affecter les points d'insertion des attributs de l'ancien bloc aux attributs du nouveau bloc.

(progn

(setq propriete(subst (cons '10 (nth a ldxyz)) (assoc '10 propriete) propriete)) ;Affecte le point d'insertion de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '50 (nth a ldangle)) (assoc '50 propriete) propriete)) ;Affecte l'angle de rotation de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '8 (nth a ldcalque)) (assoc '8 propriete) propriete)) ;Affecte le calque de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '40 (nth a ldhauteur)) (assoc '40 propriete) propriete)) ;Affecte la hauteur de texte de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '51 (nth a ldoblique)) (assoc '51 propriete) propriete)) ;Affecte l'angle de texte oblique de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '7 (nth a ldstyle)) (assoc '7 propriete) propriete)) ;Affecte le style de texte de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '72 (nth a ldjustificationh)) (assoc '72 propriete) propriete)) ;Affecte la justification horizontale de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '73 (nth a ldjustificationv)) (assoc '73 propriete) propriete)) ;Affecte la justification verticale de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '11 (nth a ldjustification)) (assoc '11 propriete) propriete)) ;Affecte les coordonnées correspondant à la justification du texte de l'attribut de l'ancien bloc (différent de 0 lorsque les codes 72 ou 73 sont différents de 0).

(setq propriete(subst (cons '41 (nth a ldfacteurx)) (assoc '41 propriete) propriete)) ;Affecte le facteur X de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '71 (nth a ldmiroir)) (assoc '71 propriete) propriete)) ;Affecte l'effet miroir de l'attribut de l'ancien bloc.

(setq propriete(subst (cons '210 (nth a ldextrusion)) (assoc '210 propriete) propriete)) ;Affecte la direction de l'extrusion de l'attribut de l'ancien bloc.

)

(entmod propriete)

(entupd entite)

(setq c 1)

)

(setq a(+ a 1))

)

(progn

;

;L'étiquette du nouveau bloc n'est pas en correspondance avec une étiquette

;de l'ancien bloc.

;

(setq a 0)

(while (and (> (length ld1) a) (= b nil)) ;Vérifie que l'étiquette existe parmi les étiquettes de l'ancien bloc.

(if (= (strcase (nth a ld1)) (strcase (cdr(assoc '2 propriete)))) ;L'étiquette existe parmi les étiquettes de l'ancien bloc.

(progn

(setq propriete(subst(cons '1 (nth a ld2)) (assoc '1 propriete) propriete)) ;Affecte la valeur contenue dans l'attribut de l'ancien bloc.