[RESOLU] Récuper données d'un bloc vers un autre bloc

[nen]

Bonjour le forum,

J’aurais besoin de votre aide :D .

Je cherche un lisp si cela existe, peut-être que la commande existe déjà dans AutoCAD :huh: .

Je voudrais remplacer un bloc1 qui contient des attributs par un autre bloc2 avec un nom différent avec les attributs identiques au bloc1 et récupérer les données du bloc1 et remplir le bloc2 automatiquement.

 

Merci d'avance de votre aide

Meilleures salutations

[Patrick_35]

Salut

 

Avec RBLOC

 

@+

[nen]

Salut,

 

Je te remercie pour ton message :) .

J’ai trouvé mon bonheur sur le site c’est un de tes lisp « CAT » ci-joint, je l’ai testé quelques blocs et il répond à mes attentes… pour le moment :D .

Je vais essayer le lisp « RBLOC » avec mes différents blocs.

Mais qu’elle est la différence entre les deux lisp ? :huh:

 

Merci

Meilleures salutations

Cat.lsp

[Patrick_35]

Salut

 

J'avais compris que tu voulais remplacer un bloc par un autre tout en conservant les attributs, ce que fait rbloc.

Si c'est juste recopier la valeur d'attributs d'un bloc vers d'autres, cat le fait très bien.

 

@+

[Jbrosteaux]

Votre Lisp fonctionne, mais il ne recopie pas les informations dans les bon attributs souhaités. Que faire pour amélioré ce Lisp?

[zebzeb]

Bonjour,

 

Le lisp RBloc fonctionne très bien je l’utilise régulière (au passage encore merci Patrick :D )

 

Pour que le remplacement s’effectue correctement il faut que les étiquettes des 2 blocs portent le même nom. Il suffit ensuite de synchroniser le nouveau bloc

 

A noter que Rbloc fonctionne également avec les blocs dynamiques

 

Cordialement

[nen]

Bonjour le forum,

 

Je me permet de revenir sur le sujet :-)

 

J'ai un bloc, on l'appeler bloc1, avec les attributs renseigné ci-dessous:

DESIGNATION
NUMERO
LONGUEUR
SURFACE

 

J'aimerais importer les données ci-dessus dans le bloc2 avec les attributs:

DESIGNATION
NUMERO
SURFACE

 

J'ai essayé avec le lisp "CAT" comme il n'y a pas le même nombre d'attribut, dans l'attribut SURFACE il m'importe la LONGUEUR :( .

J'ai essayer le lisp RBLOC.lsp, j'ai le message suivant: le fichier RBLOC.DCL est introuvable.

 

PS: j'ai AutoCAD 2018 Est-ce le problème ?

 

 

Merci d'avance

Meilleures salutations

[PHILPHIL]

hello

 

 

il faut que les blocs soit implantés dans le meme calque

 

commande : MDA

 

selectionner les données a copier de l'un aux autres en cochant les cases

 

a+

 

Phil

 

 

 

(defun c:mda (/)
 (setvar "cmdecho" 0)
 (setvar "CURSORSIZE" 10)
 (setq osm (getvar "osmode"))
 (if (and (setq source (car (entsel "\nCLIQUER SUR LE BLOC DE REFERENCE : ")))
          (setq source (vlax-ename->vla-object source))
          (= (vla-get-objectname source) "AcDbBlockReference")
     )
   (progn (setq layerbloc (vla-get-layer source)
                namebloc  (vla-get-effectivename source)
          )
   )
 )
 (setq compt 0
       propdynnom nil
       propdynnom2 nil
       propdynnom3 nil
       pop2 nil
 )
 (foreach att (vlax-invoke source 'getattributes)
   (setq propdynnom2 (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) propdynnom2))
 )
 (setq propdynnom (vl-sort propdynnom2 (function (lambda (p1 p2) (< (car p1) (car p2))))))
 (prompt "\nSELECTIONNER LES BLOCS A MODIFIER:")
 (setq selinsert (ssget (list (cons 0 "INSERT") (cons 8 layerbloc))))
 (setq com (sslength selinsert))
 (boitepropdyn3)
 (foreach att (vlax-invoke source 'getattributes)
   (progn
     (if (member (vla-get-tagstring att) listeparam)
       (setq propdynnom3 (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) propdynnom3))
     )
   )
 )
 (setvar "CURSORSIZE" 100)
 (setq compt 0)
 (acet-ui-progress-init "Avancement" com)
 (while (< compt com)
;;;    (boiteavancement)
   (if (= (vla-get-effectivename (vlax-ename->vla-object (cdr (assoc -1 (entget (ssname selinsert compt))))))
          namebloc
       )
     (progn
       (foreach bidyn propdynnom3
         (progn (setq nomprop (car bidyn)
                      valprop (cdr bidyn)
                )
                (foreach prop (vlax-invoke (vlax-ename->vla-object (cdr (assoc -1 (entget (ssname selinsert compt)))))
                                           'getattributes
                              )
                  (if (= (vla-get-tagstring prop) nomprop)
                    (vla-put-textstring prop valprop)
                  )
                )
         )
       )
     )
   )
;;;    (prompt (strcat "\rENTITE(S) TRAITEE(S) : "
;;;                    (rtos compt 2 0)
;;;                    " SUR : "
;;;                    (rtos com 2 0)
;;;            )
;;;    )
   (acet-ui-progress-init (strcat "Avancement " (rtos (/ (* compt 100) (float com)) 2 2) " %") com)
   (acet-ui-progress-safe compt)
   (setq compt (1+ compt))
 )
 (acet-ui-progress-done)
 (setvar "osmode" osm)
 (princ)
)

 

 

(defun boitepropdyn3 (/ tmp file fuzz
                     ;;ret
                     pn av dcl_id val)
 (setq tmp  (vl-filename-mktemp "Tmp.dcl")
       file (open tmp "w")
       ret  nil
 )
 (write-line (strcat "DynBlkProps:dialog{label=\"Blocs dynamiques\";"
                     "
             :text{label=\"Nom du bloc : \""
                     (vl-prin1-to-string namebloc)
                     ";}
             :text{label=\"Nombre de bloc : "
                     (itoa com)
                     "\"; }

             :boxed_column{label=\"Propriétés dynamiques\";"
             )
             file
 )
 (foreach pn propdynnom
   (progn (if (= (numberp (cdr pn)) nil)
            (setq lab1 (strcat (car pn) "  =  " (cdr pn)))
            (setq lab1 (strcat (car pn) "  =  " (rtos (cdr pn) 2)))
          )
          (write-line (strcat ":row{:toggle {key = \"" (car pn) "\"; label =" (vl-prin1-to-string lab1) ";}}")
                      file
          )
   )
 )
 (write-line "}spacer;ok_cancel;}" file)
 (close file)
 (setq dcl_id (load_dialog tmp))
 (if (not (new_dialog "DynBlkProps" dcl_id))
   (exit)
 )
 (action_tile
   "accept"
   "(foreach p propdynnom
(if (assoc (car p ) POP2)
(setq val (nth (atoi (get_tile (car p ))) (cdr (assoc (car p ) POP2))))
(setq val (get_tile (car p ))))

(if (and val (/= val \"\"))
(setq ret (cons (cons (car p ) val) ret)))
)
(and (not ret) (setq ret T))
(done_dialog)"
 )
 (action_tile "cancel" "(setq ret nil)")
 (start_dialog)
 (unload_dialog dcl_id)
 (vl-file-delete tmp)
 (setq listeparam nil)
 (foreach p ret
   (if (= (atoi (cdr p)) 1)
     (setq listeparam (cons (car p) listeparam))
   )
 )
)

[lili2006]

Bonsoir à toutes et tous,

J'ai essayer le lisp RBLOC.lsp, j'ai le message suivant: le fichier RBLOC.DCL est introuvable.

Le .DCL doit lui aussi faire partie des chemins de recherche,...

 

PS: j'ai AutoCAD 2018 Est-ce le problème ?

Non,

[nen]

hello

 

 

il faut que les blocs soit implantés dans le meme calque

 

commande : MDA

 

selectionner les données a copier de l'un aux autres en cochant les cases

 

a+

 

Phil

 

 

 

(defun c:mda (/)
 (setvar "cmdecho" 0)
 (setvar "CURSORSIZE" 10)
 (setq osm (getvar "osmode"))
 (if (and (setq source (car (entsel "\nCLIQUER SUR LE BLOC DE REFERENCE : ")))
          (setq source (vlax-ename->vla-object source))
          (= (vla-get-objectname source) "AcDbBlockReference")
     )
   (progn (setq layerbloc (vla-get-layer source)
                namebloc  (vla-get-effectivename source)
          )
   )
 )
 (setq compt 0
       propdynnom nil
       propdynnom2 nil
       propdynnom3 nil
       pop2 nil
 )
 (foreach att (vlax-invoke source 'getattributes)
   (setq propdynnom2 (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) propdynnom2))
 )
 (setq propdynnom (vl-sort propdynnom2 (function (lambda (p1 p2) (< (car p1) (car p2))))))
 (prompt "\nSELECTIONNER LES BLOCS A MODIFIER:")
 (setq selinsert (ssget (list (cons 0 "INSERT") (cons 8 layerbloc))))
 (setq com (sslength selinsert))
 (boitepropdyn3)
 (foreach att (vlax-invoke source 'getattributes)
   (progn
     (if (member (vla-get-tagstring att) listeparam)
       (setq propdynnom3 (cons (cons (vla-get-tagstring att) (vla-get-textstring att)) propdynnom3))
     )
   )
 )
 (setvar "CURSORSIZE" 100)
 (setq compt 0)
 (acet-ui-progress-init "Avancement" com)
 (while (< compt com)
;;;    (boiteavancement)
   (if (= (vla-get-effectivename (vlax-ename->vla-object (cdr (assoc -1 (entget (ssname selinsert compt))))))
          namebloc
       )
     (progn
       (foreach bidyn propdynnom3
         (progn (setq nomprop (car bidyn)
                      valprop (cdr bidyn)
                )
                (foreach prop (vlax-invoke (vlax-ename->vla-object (cdr (assoc -1 (entget (ssname selinsert compt)))))
                                           'getattributes
                              )
                  (if (= (vla-get-tagstring prop) nomprop)
                    (vla-put-textstring prop valprop)
                  )
                )
         )
       )
     )
   )
;;;    (prompt (strcat "\rENTITE(S) TRAITEE(S) : "
;;;                    (rtos compt 2 0)
;;;                    " SUR : "
;;;                    (rtos com 2 0)
;;;            )
;;;    )
   (acet-ui-progress-init (strcat "Avancement " (rtos (/ (* compt 100) (float com)) 2 2) " %") com)
   (acet-ui-progress-safe compt)
   (setq compt (1+ compt))
 )
 (acet-ui-progress-done)
 (setvar "osmode" osm)
 (princ)
)

 

 

(defun boitepropdyn3 (/ tmp file fuzz
                     ;;ret
                     pn av dcl_id val)
 (setq tmp  (vl-filename-mktemp "Tmp.dcl")
       file (open tmp "w")
       ret  nil
 )
 (write-line (strcat "DynBlkProps:dialog{label=\"Blocs dynamiques\";"
                     "
             :text{label=\"Nom du bloc : \""
                     (vl-prin1-to-string namebloc)
                     ";}
             :text{label=\"Nombre de bloc : "
                     (itoa com)
                     "\"; }

             :boxed_column{label=\"Propriétés dynamiques\";"
             )
             file
 )
 (foreach pn propdynnom
   (progn (if (= (numberp (cdr pn)) nil)
            (setq lab1 (strcat (car pn) "  =  " (cdr pn)))
            (setq lab1 (strcat (car pn) "  =  " (rtos (cdr pn) 2)))
          )
          (write-line (strcat ":row{:toggle {key = \"" (car pn) "\"; label =" (vl-prin1-to-string lab1) ";}}")
                      file
          )
   )
 )
 (write-line "}spacer;ok_cancel;}" file)
 (close file)
 (setq dcl_id (load_dialog tmp))
 (if (not (new_dialog "DynBlkProps" dcl_id))
   (exit)
 )
 (action_tile
   "accept"
   "(foreach p propdynnom
(if (assoc (car p ) POP2)
(setq val (nth (atoi (get_tile (car p ))) (cdr (assoc (car p ) POP2))))
(setq val (get_tile (car p ))))

(if (and val (/= val \"\"))
(setq ret (cons (cons (car p ) val) ret)))
)
(and (not ret) (setq ret T))
(done_dialog)"
 )
 (action_tile "cancel" "(setq ret nil)")
 (start_dialog)
 (unload_dialog dcl_id)
 (vl-file-delete tmp)
 (setq listeparam nil)
 (foreach p ret
   (if (= (atoi (cdr p)) 1)
     (setq listeparam (cons (car p) listeparam))
   )
 )
)

 

SalutPhilphil,

 

Je te remercie pour ton message :D .

J'ai donc créé les deux lisp et changé dans le dessin contenant les deux types d'étiquettes.

Malheureusement j'ai peut-être malfait quelques choses, car aucune modification s'applique.

La boîte de dialogue avec les cases à cocher s'ouvre bien mais, aucune modification s'applique ?

 

Ci-dessous le lien avec les deux lisp et le dwg

 

https://www.dropbox.com/sh/ph9xe4flege8ivw/AAA8lsYYN0rOtwGOr-Uo1CAGa?dl=0

 

Merci d'avance

Meilleures salutations

[nen]

Bonsoir à toutes et tous,

 

Le .DCL doit lui aussi faire partie des chemins de recherche,...

 

 

Non,

 

 

Salut lili2006,

 

Je te remercie pour ton message :D .

Normalement là ou il devrait être placé, il fait bien partie des chemins de recherche.

En faite cherchant sur mon disque dure, je n'ai pas le fichier "RBLOC.DCL" voilà pourquoi cela ne fonctionne pas et je n'arrive pas à le télécharger sur la page de Patrick_35 :(

 

http://cadxp.com/topic/11038-lisps-de-patrick-35/

 

Merci de ton aide

Meilleures salutations

[lili2006]

Bonjour à toutes et tous,

Salut nen, Et depuis cette Adresse ?

[nen]

Bonjour à toutes et tous,

Salut nen, Et depuis cette Adresse ?

 

Bonjour le forum :)

Salut lili2006 ;) ,

 

Je te remercie en effet j'ai pu télécharger le fichier, merci :D

 

Merci de ton aide

Meilleures salutations

[Patrick_35]

En faite cherchant sur mon disque dure, je n'ai pas le fichier "RBLOC.DCL" voilà pourquoi cela ne fonctionne pas et je n'arrive pas à le télécharger sur la page de Patrick_35 :(

 

http://cadxp.com/topic/11038-lisps-de-patrick-35/

Salut

 

Je viens de télécharger RBLOC depuis le lien que tu donnes et je retrouve bien le DCL :huh:

 

@+

[nen]

Salut

 

Je viens de télécharger RBLOC depuis le lien que tu donnes et je retrouve bien le DCL :huh:

 

@+

 

Salut,

 

J'ai réessayé et en effet cela a fonctionné :D .

La première fois j'avais eu un message d'erreur, maintenant c'est ok.

C'est peut-être mon anti-virus ou le pare-feu qui te temps en temps me joue des tours :-)

Je te remercie pour ton aide et tes lisps qui nous simplifie bien la vie ;-)

 

Malheureusement dans mon actuellement j'ai des vieux plans avec des anciens bloc/attribut.

J'aurais voulu les récupérer dans nos nouveaux bloc/attribut, j'ai essayé avec les lisp CAT et RBLOC et cela ne va pas car je n'ai pas le même nombre et les mêmes noms d'attribut.

 

Par contre le lisp de PHILPHIL de vrai faire le boulot malheureusement rien ne se passe et je sais pas pourquoi ? :(

 

Ci-dessous le lien avec les deux lisp de PHILPHIL et le dwg

https://www.dropbox....Or-Uo1CAGa?dl=0

 

Meilleures salutations

[Patrick_35]

Salut

 

Une modification de CAT pour recopier la valeur des étiquettes si elles ont le même nom.

;;;=================================================================
;;;
;;; CATP.LSP V1.00
;;;
;;; Copier des attributs si les étiquettes sont identiques
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:catp(/ att bl doc ent s sel *errcat*)

;=========================================================================
; Gestion des erreurs
;=========================================================================

 (defun *errcat* (msg)
   (or (member (strcase msg) '("FUNCTION CANCELLED" ""QUIT / EXIT ABORT"" "FONCTION ANNULEE" "QUITTER / SORTIR ABANDON"))
     (princ (strcat "\nErreur : " msg))
   )
   (vla-endundomark doc)
   (setq *error* s)
   (princ)
 )

 (vl-load-com)
 (setq s *error*
*error* *errcat*
doc (vla-get-activedocument (vlax-get-acad-object))
 )
 (vla-startundomark doc)
 (and	(setq ent (entsel "\nSélectionnez le bloc d'origine : "))
(setq ent (vlax-ename->vla-object (car ent)))
(eq (vla-get-objectname ent) "AcDbBlockReference")
(eq (vla-get-hasattributes ent) :vlax-true)
(setq att (vlax-invoke ent 'getattributes))
   (progn
     (while (setq ent (entsel "\nSélectionnez les blocs destinataires : "))
(setq ent (vlax-ename->vla-object (car ent)))
(and (eq (vla-get-objectname ent) "AcDbBlockReference")
  (mapcar '(lambda(a / B)
	    (foreach b (vlax-invoke ent 'getattributes)
	      (and (eq (strcase (vla-get-tagstring a)) (strcase (vla-get-tagstring B)))
		(vla-put-textstring b (vla-get-textstring a))
	      )
	    )
	  )
	  att
  )
)
     )
   )
 )
 (vla-endundomark doc)
 (setq *error* s)
 (princ)
)

(setq nom_lisp "CATP")
(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)

 

@+

[PHILPHIL]

hello

 

mon lisp fonctionne mais ils faut que les deux blocs soit dans le meme calque

 

ne fait pas deux fichiers *.lsp par contre

 

copie tout dans un seul fichier *.lsp

d'ailleurs un fichier *.lsp peut contenir plein de lisp tant que les parenthèses sont bien ouvertes et refermées

 

 

dans le lisp remplace

 

(setq selinsert (ssget (list (cons 0 "INSERT") (cons 8 layerbloc))))

par

 

(setq selinsert (ssget (list (cons 0 "INSERT") )))

 

ca ne verifiera plus que les blocs soient dans le meme calque

 

mais il faut quand meme que dans les blocs il y est des attributs avec des noms en commun

 

 

a+

 

Phil

[nen]

Salut

 

Une modification de CAT pour recopier la valeur des étiquettes si elles ont le même nom.

;;;=================================================================
;;;
;;; CATP.LSP V1.00
;;;
;;; Copier des attributs si les étiquettes sont identiques
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:catp(/ att bl doc ent s sel *errcat*)

;=========================================================================
; Gestion des erreurs
;=========================================================================

 (defun *errcat* (msg)
   (or (member (strcase msg) '("FUNCTION CANCELLED" ""QUIT / EXIT ABORT"" "FONCTION ANNULEE" "QUITTER / SORTIR ABANDON"))
     (princ (strcat "\nErreur : " msg))
   )
   (vla-endundomark doc)
   (setq *error* s)
   (princ)
 )

 (vl-load-com)
 (setq s *error*
*error* *errcat*
doc (vla-get-activedocument (vlax-get-acad-object))
 )
 (vla-startundomark doc)
 (and	(setq ent (entsel "\nSélectionnez le bloc d'origine : "))
(setq ent (vlax-ename->vla-object (car ent)))
(eq (vla-get-objectname ent) "AcDbBlockReference")
(eq (vla-get-hasattributes ent) :vlax-true)
(setq att (vlax-invoke ent 'getattributes))
   (progn
     (while (setq ent (entsel "\nSélectionnez les blocs destinataires : "))
(setq ent (vlax-ename->vla-object (car ent)))
(and (eq (vla-get-objectname ent) "AcDbBlockReference")
  (mapcar '(lambda(a / B)
	    (foreach b (vlax-invoke ent 'getattributes)
	      (and (eq (strcase (vla-get-tagstring a)) (strcase (vla-get-tagstring B)))
		(vla-put-textstring b (vla-get-textstring a))
	      )
	    )
	  )
	  att
  )
)
     )
   )
 )
 (vla-endundomark doc)
 (setq *error* s)
 (princ)
)

(setq nom_lisp "CATP")
(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)

 

@+

 

Salut Patrick,

 

Je te remercie pour ton message et pour la modifications du lisp .

En effet il fonctionne nickel ;)

 

 

Meilleures salutations

[nen]

hello

 

mon lisp fonctionne mais ils faut que les deux blocs soit dans le meme calque

 

ne fait pas deux fichiers *.lsp par contre

 

copie tout dans un seul fichier *.lsp

d'ailleurs un fichier *.lsp peut contenir plein de lisp tant que les parenthèses sont bien ouvertes et refermées

 

 

dans le lisp remplace

 

(setq selinsert (ssget (list (cons 0 "INSERT") (cons 8 layerbloc))))

par

 

(setq selinsert (ssget (list (cons 0 "INSERT") )))

 

ca ne verifiera plus que les blocs soient dans le meme calque

 

mais il faut quand meme que dans les blocs il y est des attributs avec des noms en commun

 

 

a+

 

Phil

 

Salut,

 

J'ai donc fusionné les deux lisp en un "mda.lsp" et changé la ligne comme convenu.

Malheureusement le lisp ne fonctionne toujours pas.

Jusqu'à la boîte de dialogue avec les case à cocher c'est ok.

Une fois cocher, je clique sur OK, il n'y a aucun changement :(

 

Commande: _appload mda.lsp correctement chargé(s)

Commande: MDA

CLIQUER SUR LE BLOC AVEC LES DONNEES :
SELECTIONNER LES BLOCS A IMPORTER LES DONNEES:
Sélectionner des objets: 1 trouvé(s)

Sélectionner des objets:

Commande:

 

 

J'ai mise à jour le lisp dans le dossier ci-dessous:

https://www.dropbox.com/sh/ph9xe4flege8ivw/AAA8lsYYN0rOtwGOr-Uo1CAGa?dl=0

 

Si chez toi cela fonctionne est-ce mon fichier dwg ou les blocs qui a/ont un problème ?

 

 

Merci de ton aide

Meilleures salutations