Redéfinir les points d\'insertion des blocs

[LUDWIG]

Un lisp qui redéfinit tous les blocs d'un dessin quand leur point d'insertion est défini hors du bloc.

 

Les Xrefs ne subissent pas le lisp.

Les blocs anonymes sont remplacés par des blocs nommés.

 

J'ai essayer de tester toutes les configurations possibles. Dites moi ce que vous en pensez et renvoyez les problèmes.

 

ATTENTION POST EDITE : sur certains cas particuliers, les résultats sont inattendus. Voir message posté le 14/9/2005 à 17:10 dans ce sujet même.

 

ATTENTION j'ai édité le code (point virgule sur ;(assoc 4 bloc_prop) car ce code peut ne pas exister dans le bloc d'origine)

 

  ;**********************************************************************************************************************************************************
;REDEFINIR POINTS DE BASE DES BLOCS
;**********************************************************************************************************************************************************
;Redéfini les blocs dont le point d'insertion est hors de l'emprise du bloc

(defun c:repib () ;RE définir  les  P oints  d' I nsertion  des  B locs

 ;pas de messages pendant la commande
(setq cmdechOLD (getvar "cmdecho"))
(setvar "cmdecho" 0)
 
 ;pas d'accrochage objets pendant la commande
(setq OSMOLD (getvar "Osmode"))
(command "-accrobj" "auc")
 
;se place en scu général
 (command "scu" "Général")

;affiche et libère tous les calques
 (COMMAND "-calque" "L" "*" "AC" "*" "D" "*" "E" "0" "")

 (initget 1 "O N")
 (setq purger (getkword "Voudrez-vous purger ? (O ou N) "))

;**********************************************************************************************************************************
;ETAPE 0 : Récupération des données du bloc
;**********************************************************************************************************************************

 (setq bloc_prop (tblnext "block" T))

;Propriétés du bloc
 (while bloc_prop
   (setq bloc_nom (cdr (assoc 2 bloc_prop)))
   (setq constituant_id (cdr (assoc -2 bloc_prop)))
   (setq bloc_pi (cdr (assoc 10 bloc_prop)))
   (setq bloc_X (car bloc_pi))
   (setq bloc_Y (cadr bloc_pi))
   (setq bloc_Z (caddr bloc_pi))
   (setq RIEN "VRAI")

;Ne fait le traitement que si le bloc n'est pas une référence externe (bit 4 du drapeau 70)
   (if	(= (logand (cdr (assoc 70 bloc_prop)) 4) 0)
     (progn

;Test si le bloc a au moins un constituant possédant une GetBoundingBox
(while constituant_id
  (if (not (vl-catch-all-error-p
	     (vl-catch-all-apply
	       '(lambda	()
		  (vla-GetBoundingBox
		    (vlax-ename->vla-object
		      constituant_id
		      ) ;_ Fin de vlax-ename->vla-object
		    'mini
		    'maxi
		    ) ;_ Fin de vla-GetBoundingBox
		  ) ;_ Fin de lambda
	       ) ;_ Fin de vl-catch-all-apply
	     ) ;_ Fin de vl-catch-all-error-p
	   ) ;_ Fin de not
    (setq RIEN "FAUX")
    ) ;_ Fin de if
  (setq constituant_id (entnext constituant_id))

  ) ;_ Fin de while

(if (= RIEN "FAUX")
  (progn

;Coordonnées du premier constituant ayant une Gbb
    (setq maxi (vlax-safearray->list maxi))
    (setq mini (vlax-safearray->list mini))
    (setq Xmini (car mini))
    (setq Ymini (cadr mini))
    (setq Zmini (caddr mini))
    (setq Xmaxi (car maxi))
    (setq Ymaxi (cadr maxi))
    (setq Zmaxi (caddr maxi))

;Emprise du bloc (test l'emprise de chaque constituant et renvoie les X,Y et Z mini et maxi	       
    (setq constituant_id (cdr (assoc -2 bloc_prop)))
    (while constituant_id
      (if (= (vl-catch-all-error-p
	       (vl-catch-all-apply
		 '(lambda ()
		    (vla-GetBoundingBox
		      (vlax-ename->vla-object
			constituant_id
			) ;_ Fin de vlax-ename->vla-object
		      'mini
		      'maxi
		      ) ;_ Fin de vla-GetBoundingBox
		    ) ;_ Fin de lambda
		 ) ;_ Fin de vl-catch-all-apply
	       ) ;_ Fin de vl-catch-all-error-p
	     nil
	     ) ;_ Fin de =
	(progn
	  (vla-GetBoundingBox
	    (vlax-ename->vla-object constituant_id)
	    'mini
	    'maxi
	    ) ;_ Fin de vla-GetBoundingBox
	  (setq maxi (vlax-safearray->list maxi))
	  (setq mini (vlax-safearray->list mini))
	  (if (< (car mini) Xmini)
	    (setq Xmini (car mini))
	    ) ;_ Fin de if
	  (if (< (cadr mini) Ymini)
	    (setq Ymini (cadr mini))
	    ) ;_ Fin de if
	  (if (< (caddr mini) Zmini)
	    (setq Zmini (caddr mini))
	    ) ;_ Fin de if
	  (if (> (car maxi) Xmaxi)
	    (setq Xmaxi (car maxi))
	    ) ;_ Fin de if
	  (if (> (cadr maxi) Ymaxi)
	    (setq Ymaxi (cadr maxi))
	    ) ;_ Fin de if
	  (if (> (caddr maxi) Zmaxi)
	    (setq Zmaxi (caddr maxi))
	    ) ;_ Fin de if
	  ) ;_ Fin de progn
	) ;_ Fin de if
      (setq constituant_id (entnext constituant_id))
      ) ;_ Fin de while

;**********************************************************************************************************************************
;ETAPE 1 : CREATION DU NOUVEAU BLOC (si le point d'insertion est hors de l'emprise)
;**********************************************************************************************************************************

    (if	(or (< bloc_X Xmini)
	    (< bloc_Y Ymini)
	    (< bloc_Z Zmini)
	    (> bloc_X Xmaxi)
	    (> bloc_Y Ymaxi)
	    (> bloc_Z Zmaxi)
	    ) ;_ Fin de or
      (setq redef "oui")
      (setq redef "non")
      ) ;_ Fin de if

    (if	(= redef "oui")
      (progn

;calcul du nouveau point du bloc
	(setq
	  Xnew (+ (- (/ (+ Xmaxi Xmini) 2) bloc_X)
		  bloc_X
		  ) ;_ Fin de +
	  ) ;_ Fin de setq
	(setq
	  Ynew (+ (- (/ (+ Ymaxi Ymini) 2) bloc_Y)
		  bloc_Y
		  ) ;_ Fin de +
	  ) ;_ Fin de setq
	(setq
	  Znew (+ (- (/ (+ Zmaxi Zmini) 2) bloc_Z)
		  bloc_Z
		  ) ;_ Fin de +
	  ) ;_ Fin de setq
	(setq bloc_pi-new (list Xnew Ynew Znew))

;Recherche du nom pour le nouveau bloc (suppression éventuel de *)
	(if (/= (substr bloc_nom 1 1) "*")
	  (progn
	    (setq i 1)
	    (while (tblsearch "block"
			      (setq nouveau_bloc_nom
				     (strcat bloc_nom
					     "_old_"
					     (itoa i)
					     ) ;_ Fin de strcat
				    ) ;_ Fin de setq
			      ) ;_ Fin de tblsearch
	      (setq i (+ 1 i))
	      ) ;_ Fin de while
	    ) ;_ Fin de progn

	  (progn
	    (setq nouveau_bloc_nom
		   (strcat "`" bloc_nom)
		  ) ;_ Fin de setq

	    (setq bloc_nom
		   (strcat
		     (substr bloc_nom
			     2
			     (strlen bloc_nom)
			     ) ;_ Fin de substr
		     ) ;_ Fin de strcat
		  ) ;_ Fin de setq

	    (if	(tblsearch "block" bloc_nom)
	      (progn

		(setq i 1)
		(while (tblsearch "block"
				  (strcat bloc_nom
					  "_redef_"
					  (itoa (+ i 1))
					  ) ;_ Fin de strcat
;_ Fin de setq
				  ) ;_ Fin de tblsearch

		  (setq i (+ 1 i))
		  ) ;_ Fin de while
		(setq bloc_nom (strcat bloc_nom
				       "_redef_"
				       (itoa (+ i 1))
				       ) ;_ Fin de strcat
		      ) ;_ Fin de setq
		) ;_ Fin de progn
	      ) ;_ Fin de if
	    ) ;_ Fin de progn

	  ) ;_ Fin de if

;le bloc est renommé (s'il n'est pas anonyme)
	(if
	  (not
	    (= (substr (cdr (assoc 2 bloc_prop)) 1 1)
	       "*"
	       ) ;_ Fin de =
	    ) ;_ Fin de not
	   (command "_-rename"
		    "BL"
		    bloc_nom
		    nouveau_bloc_nom
		    ) ;_ Fin de command
	   ) ;_ Fin de if

;Détermination de la valeur du drapeau 70
	(if
	  (/= (logand (cdr (assoc 70 bloc_prop)) 1) 0)
	   (setq typ (- (cdr (assoc 70 bloc_prop)) 1))
	   (setq typ (cdr (assoc 70 bloc_prop)))
	   ) ;_ Fin de if

;le nouveau bloc est créé (dans la table) avec l'ancien nom du bloc et les nouvelles coordonnées
	(entmake (list (cons 0 "block")
		       (cons 2 bloc_nom)
		       (cons 70 typ)
		       ;(assoc 4 bloc_prop)
		       (cons 10 bloc_pi-new)
		       ) ;_ Fin de list
		 ) ;_ Fin de entmake

;les constituants de l'ancien bloc sont dupliqués dans le nouveau bloc
	(setq constituant_id (cdr (assoc -2 bloc_prop)))
	(while constituant_id
	  (setq constituant (entget constituant_id))
	  (setq	constituant
		 (vl-remove
		   (assoc -1 constituant)
		   constituant
		   ) ;_ Fin de vl-remove
		) ;_ Fin de setq
;identifiant unique généré par autocad
	  (setq	constituant
		 (vl-remove
		   (assoc 5 constituant)
		   constituant
		   ) ;_ Fin de vl-remove
		) ;_ Fin de setq
;identifiant unique généré par autocad
	  (setq	constituant
		 (vl-remove
		   (assoc 330 constituant)
		   constituant
		   ) ;_ Fin de vl-remove
		) ;_ Fin de setq
;identifiant unique généré par autocad
	  (entmake constituant)
	  (setq	constituant_id
		 (entnext constituant_id)
		) ;_ Fin de setq
	  ) ;_ Fin de while
	(entmake '((0 . "endblk")))

;**********************************************************************************************************************************
;ETAPE 2 : REMPLACEMENT DES BLOCS DANS LE DESSIN
;**********************************************************************************************************************************
	(setq bloc1
	       (ssget "X"
		      (list (cons 2 nouveau_bloc_nom))
		      ) ;_ Fin de ssget
	      ) ;_ Fin de setq
	(if bloc1
	  (progn

	    (setq dist_X
		   (- (/ (+ Xmaxi Xmini) 2) bloc_X)
		  ) ;_ Fin de setq
	    (setq dist_Y
		   (- (/ (+ Ymaxi Ymini) 2) bloc_Y)
		  ) ;_ Fin de setq
	    (setq dist_Z
		   (- (/ (+ Zmaxi Zmini) 2) bloc_Z)
		  ) ;_ Fin de setq

	    (setq jeu
		   (ssget
		     "x"
		     (list (cons 2 nouveau_bloc_nom))
		     ) ;_ Fin de ssget
		  ) ;_ Fin de setq
	    (setq n 0)
	    (repeat (sslength jeu)
	      (setq bloc_traité (ssname jeu n))
	      (setq prop_bloc_traité
		     (entget bloc_traité)
		    ) ;_ Fin de setq

;récupération des échelles X Y Z du bloc traité
	      (setq ech_X_bloc_traité
		     (cdr
		       (assoc
			 41
			 (entget
			   bloc_traité
			   ) ;_ Fin de entget
			 ) ;_ Fin de assoc
		       ) ;_ Fin de cdr
		    ) ;_ Fin de setq
	      (setq ech_Y_bloc_traité
		     (cdr
		       (assoc
			 42
			 (entget
			   bloc_traité
			   ) ;_ Fin de entget
			 ) ;_ Fin de assoc
		       ) ;_ Fin de cdr
		    ) ;_ Fin de setq
	      (setq ech_Z_bloc_traité
		     (cdr
		       (assoc
			 43
			 (entget
			   bloc_traité
			   ) ;_ Fin de entget
			 ) ;_ Fin de assoc
		       ) ;_ Fin de cdr
		    ) ;_ Fin de setq

;récupération des coordonnées d'insertion du bloc traité
	      (setq pi_bloc_traité
		     (cdr (assoc
			    10
			    (entget
			      bloc_traité
			      ) ;_ Fin de entget
			    ) ;_ Fin de assoc
			  ) ;_ Fin de cdr
		    ) ;_ Fin de setq
	      (setq pi_X_bloc_traité
		     (car pi_bloc_traité)
		    ) ;_ Fin de setq
	      (setq pi_Y_bloc_traité
		     (car
		       (cdr
			 pi_bloc_traité
			 ) ;_ Fin de cdr
		       ) ;_ Fin de car
		    ) ;_ Fin de setq
	      (setq pi_Z_bloc_traité
		     (car
		       (cdr
			 (cdr
			   pi_bloc_traité
			   ) ;_ Fin de cdr
			 ) ;_ Fin de cdr
		       ) ;_ Fin de car
		    ) ;_ Fin de setq

;Nouvelles valeurs d'insertion
;étape 1 : calcul du point avant rotation
	      (setq pi_X_nouveau_bloc_traité
		     (+
		       (*
			 ech_X_bloc_traité
			 dist_X
			 ) ;_ Fin de *
		       pi_X_bloc_traité
		       ) ;_ Fin de +
		    ) ;_ Fin de setq
	      (setq pi_Y_nouveau_bloc_traité
		     (+
		       (*
			 ech_Y_bloc_traité
			 dist_Y
			 ) ;_ Fin de *
		       pi_Y_bloc_traité
		       ) ;_ Fin de +
		    ) ;_ Fin de setq
	      (setq pi_Z_nouveau_bloc_traité
		     (+
		       (*
			 ech_Z_bloc_traité
			 dist_Z
			 ) ;_ Fin de *
		       pi_Z_bloc_traité
		       ) ;_ Fin de +
		    ) ;_ Fin de setq
	      (setq pi_nouveau_bloc_traité
		     (list
		       pi_X_nouveau_bloc_traité
		       pi_Y_nouveau_bloc_traité
		       pi_Z_nouveau_bloc_traité
		       ) ;_ Fin de list
		    ) ;_ Fin de setq

;étape 2 : calcul du point avec rotation
	      (setq ang_bloc_traité
		     (cdr
		       (assoc
			 50
			 (entget
			   bloc_traité
			   ) ;_ Fin de entget
			 ) ;_ Fin de assoc
		       ) ;_ Fin de cdr
		    ) ;_ Fin de setq
;rotation du bloc traité
	      (setq dist
		     (distance pi_nouveau_bloc_traité
			       pi_bloc_traité
			       ) ;_ Fin de distance
		    ) ;_ Fin de setq
	      (setq ang
		     (angle pi_bloc_traité
			    pi_nouveau_bloc_traité
			    ) ;_ Fin de angle
		    ) ;_ Fin de setq
	      (setq pi_nouveau_bloc_traité
		     (polar
		       pi_bloc_traité
		       (+
			 ang_bloc_traité
			 ang
			 ) ;_ Fin de +
		       dist
		       ) ;_ Fin de polar
		    ) ;_ Fin de setq

;mise à jour du bloc en cours
	      (setq prop_bloc_traité
		     (subst
		       (cons 2
			     bloc_nom
			     ) ;_ Fin de cons
		       (assoc
			 2
			 prop_bloc_traité
			 ) ;_ Fin de assoc
		       prop_bloc_traité
		       ) ;_ Fin de subst
		    ) ;_ Fin de setq
	      (setq prop_bloc_traité
		     (subst
		       (cons
			 10
			 pi_nouveau_bloc_traité
			 ) ;_ Fin de cons
		       (assoc
			 10
			 prop_bloc_traité
			 ) ;_ Fin de assoc
		       prop_bloc_traité
		       ) ;_ Fin de subst
		    ) ;_ Fin de setq
	      (entmod prop_bloc_traité)
	      (setq n (+ 1 n))
	      ) ;repeat
	    ) ;progn bloc1
	  ) ;_ Fin de if
;if bloc1 (=tant qu'il y a des blocs à remplacer dans le dessin)
	) ;progn REDEF=OUI
      ) ;if REDEF=OUI
    (setq bloc_prop (tblnext "block"))
    ) ;progn RIEN=FAUX
  (setq bloc_prop (tblnext "block"))
  ) ;if RIEN=FAUX
) ;progn not référence externe
     (setq bloc_prop (tblnext "block"))
     ) ;if not référence externe
   ) ;while block

 (if (= "O" purger)
   (command "-purger" "BL" "*" "n")
   );_ Fin de if

 (setvar "Osmode" OSMOLD)
 (setvar "cmdecho" cmdechOLD)

 (princ)
 ) ;defun

 

[Edité le 29/4/2005 par LUDWIG]

 

 

[Edité le 14/9/2005 par LUDWIG]

[Patrick_35]

Génial, c'est super, bravo

J'aurai, si tu le permets, juste deux remarques à formuler

A la lecture de ton lisp, il est tout à fait possible de supprimer les deux "command" auquel tu fais appel avec en voix de conséquence, la possibilité de supprimer l'appel aux variables d'Autocad

 

Pour purger, tu peux passer par (vla-purgeall (vla-get-activedocument (vlax-get-acad-object)))

Pour le rename, je regarde ça la semaine prochaine

 

et toujours pour les command, écris les en anglais, il faut penser à nos amis d'outre atlantique ou à ceux qui n'ont pas une version française

 

@+

[LUDWIG]

Génial, c'est super, bravo

Merci ça fait plaisir... MAis je n'y serais pas arriver sans les contributions des membres de CadXp

 

il est tout à fait possible de supprimer les deux "command"

Je pensais les modifier plus tard justement. Mais pourquoi faut-il priviligier la modif direct des variables et les commandes Vlisp plutôt ques les "command" ?

-command scu : on doit pouvoir enregistrer le scu courant dans une variable, mettre le général, puis rétablir le scu enregistré en fin de programme.

-command accrobj auc peut bin sûr être remplacé par un setvar osmode ...

-command calque : je souhaitais enregistrer un état de calque, tout libérer puis rétablir l'état en fin de commande. Mais je ne savais pas comment tester si le nom de l'état que je veux donner existe déjà...

-command purger : ok je ne connaissais pas vla-purgeall

 

pour les command, écris les en anglais

des fois je ne les trouve pas justement : entres les - , _ . , et les combinaisons possibles, il faut s'y retrouver. Après faut connaître les options...

[didier]

bonjour

 

chapeau mon garçon

 

surtout qu'il me semble que tu t'es mis au Lisp il y a peu, n'est ce pas ?

 

Très belle progression,

élève qui ira loin, s'il garde sa ténacité ;) :)

 

encore bravo

 

très amicalement

 

[Tramber]

Moi aussi je dis bravo.

 

pour les command, écris les en anglais

des fois je ne les trouve pas justement : entres les - , _ . , et les combinaisons possibles, il faut s'y retrouver. Après faut connaître les options...

 

mais Tramber est là et t'indiques le bon sujet.

 

J'ai téléchargé moyennant petite participation le fichier XLS proposé par Patrick et m'en passe difficilement.....quand je passe des COMMAND ;)

[Patrick_35]

Eviter les "command" permet de ne pas toucher aux variables d'autocad, comme les accroch obj, le modemacro, attreq&attdia pour les blocs, etc... Ca fait un peu plus "Lispien" et si jamais le prog plante, ça évite à l’utilisateur final de refaire ses variables. Combien de fois on voit sur le forum, j’ai perdu ceci ou encore cela, et lorsque la variable est remise comme on le souhaite, on entend dire, mais je n’ai rien touché, je ne vois pas pourquoi elle a changée.

 

Pour trouver les _ , je me sers tout simplement du menu, toutes les commandes sont en anglais. Pour ce qui est des options, un peu de logique permet de retrouver la bonne syntaxe

 

@+

[LUDWIG]

Merci pour les félicitations...

 

Didier, oui je me suis mis au Lisp en novembre. Avant je l'utilisais mais je ne faisais que des "command" et ssget, c'était plus du script...

 

Je mettrais les futures moutures ici (utilisation de vlisp plutôt que command, ajout d'un compteur...)

[LUDWIG]

Attention, je viens de remarquer que dans certains cas particuliers, ce lisp donne des résultats inattendus. Exemple : un bloc "plat" (2D) dont le z n'est pas le même que le z du point d'insertion...

 

J'ai repéré ou étais l'erreur et je la corrige dès que possible.

 

De même, mon lisp créer un nouveau bloc et remplace l'ancien par le nouveau dans le graphique. Mais si l'ancien bloc ("toto" disons) est référencé (par un autre bloc par exemple), la référence reste sur l'ancien nom...

Par exemple, dans mon lisp, "toto" est renommé en "toto_old_1", puis un bloc correct "toto" est créé, puis les insert "toto_old_1" sont remplacés par des insert "toto". Mais si un autre bloc contenait le bloc "toto", alors à la fin de la commande, il contiendra le bloc "toto_old_1".

Donc mon but sera de modifier mon lisp pour qu'il redéfinisse directement le bloc plutôt qu'il fasse un simple "remplacement".