Aller au contenu

Subtilité lisp BLOC


zara

Messages recommandés

Bonjour,

J'utilise le lisp suivant pour éditer les blocs d'un dessin.

Cela fonctionne très bien mais je souhaiterai ne pas toucher aux hachures des blocs juste les lignes concernant le changement de couleur.

Auriez-vous une idée pour modifier le lisp pour que cela fonctionne?

 

Merci par avance

 

(defun c:norm (/ *error* adoc lst_layer func_restore-layers)
 (defun *error* (msg)
   (func_restore-layers)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun

 (defun func_restore-layers ()
   (foreach item lst_layer
     (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     (vl-catch-all-apply
       '(lambda ()
          (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
          ) ;_ end of lambda
       ) ;_ end of vl-catch-all-apply
     ) ;_ end of foreach
   ) ;_ end of defun

 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-startundomark
 (vlax-for item (vla-get-layers adoc)
   (setq lst_layer (cons (list item
                               (cons "lock" (vla-get-lock item))
                               (cons "freeze" (vla-get-freeze item))
                               ) ;_ end of list
                         lst_layer
                         ) ;_ end of cons
         ) ;_ end of setq
   (vla-put-lock item :vlax-false)
   (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))
   ) ;_ end of vlax-for
 (vlax-for blk (vla-get-blocks adoc)
   (if (and (equal (vla-get-islayout blk) :vlax-false)
            (equal (vla-get-isxref blk) :vlax-false)
            ) ;_ end of and
     (progn
       (vlax-for subent blk
         (vla-put-layer subent "0")
         (vla-put-color subent 0)
         (vla-put-lineweight subent aclnwtbyblock)
         (vla-put-linetype subent "byblock")
         ) ;_ end of vlax-for
       ) ;_ end of progn
     ) ;_ end of if
   ) ;_ end of vlax-for
 (func_restore-layers)
 (vla-endundomark adoc)
 (princ)
 ) ;_ end of defun

Lien vers le commentaire
Partager sur d’autres sites

Salut,

 

Remplace l'expression (à la fin) :

      (progn
       (vlax-for subent blk
         (vla-put-layer subent "0")
         (vla-put-color subent 0)
         (vla-put-lineweight subent aclnwtbyblock)
         (vla-put-linetype subent "byblock")
         ) ;_ end of vlax-for
       ) ;_ end of progn

par celle là :

      (progn
       (vlax-for subent blk
         (if (/= (vla-get-ObjectName subent) "AcDbHatch")
           (progn
             (vla-put-layer subent "0")
             (vla-put-color subent 0)
             (vla-put-lineweight subent aclnwtbyblock)
             (vla-put-linetype subent "byblock")
           );_ end of progn
         );_ end of if
       ) ;_ end of vlax-for
     ) ;_ end of progn

Gilles Chanteau - gileCAD -
Développements sur mesure pour AutoCAD
ADSK_Expert_Elite_Icon_S_Color_Blk_125.png

Lien vers le commentaire
Partager sur d’autres sites

Salut,

Merci pour cette réponse.

C'est un honneur pour moi de converser avec "le boss" gile.

 

J'ai remplacer la fin comme indiqué mais le lisp ne se lance plus du tout. :mellow:

Aurais je oublié quelque chose?

merci encore

 

(defun c:xcv (/ *error* adoc lst_layer func_restore-layers)
 (defun *error* (msg)
   (func_restore-layers)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun

 (defun func_restore-layers ()
   (foreach item lst_layer
     (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     (vl-catch-all-apply
       '(lambda ()
          (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
          ) ;_ end of lambda
       ) ;_ end of vl-catch-all-apply
     ) ;_ end of foreach
   ) ;_ end of defun

 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-startundomark
 (vlax-for item (vla-get-layers adoc)
   (setq lst_layer (cons (list item
                               (cons "lock" (vla-get-lock item))
                               (cons "freeze" (vla-get-freeze item))
                               ) ;_ end of list
                         lst_layer
                         ) ;_ end of cons
         ) ;_ end of setq
   (vla-put-lock item :vlax-false)
   (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))
   ) ;_ end of vlax-for
 (vlax-for blk (vla-get-blocks adoc)
   (if (and (equal (vla-get-islayout blk) :vlax-false)
            (equal (vla-get-isxref blk) :vlax-false)
            ) ;_ end of and
     (progn
       (vlax-for subent blk
         (if (/= (vla-get-ObjectName subent) "AcDbHatch")
           (progn
             (vla-put-layer subent "0")
             (vla-put-color subent 0)
             (vla-put-lineweight subent aclnwtbyblock)
             (vla-put-linetype subent "byblock")
           );_ end of progn
         );_ end of if
       ) ;_ end of vlax-for
     ) ;_ end of progn

Lien vers le commentaire
Partager sur d’autres sites

Tu n'as pas remplacé juste l'expression (progn ...), tu as remplacé toute la fin de la routine...

 

La programmation ne supporte pas l'approximation.

 

(defun c:norm (/ *error* adoc lst_layer func_restore-layers)
 (defun *error* (msg)
   (func_restore-layers)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun

 (defun func_restore-layers ()
   (foreach item lst_layer
     (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     (vl-catch-all-apply
       '(lambda ()
          (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
          ) ;_ end of lambda
       ) ;_ end of vl-catch-all-apply
     ) ;_ end of foreach
   ) ;_ end of defun

 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-startundomark
 (vlax-for item (vla-get-layers adoc)
   (setq lst_layer (cons (list item
                               (cons "lock" (vla-get-lock item))
                               (cons "freeze" (vla-get-freeze item))
                               ) ;_ end of list
                         lst_layer
                         ) ;_ end of cons
         ) ;_ end of setq
   (vla-put-lock item :vlax-false)
   (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))
   ) ;_ end of vlax-for
 (vlax-for blk (vla-get-blocks adoc)
   (if (and (equal (vla-get-islayout blk) :vlax-false)
            (equal (vla-get-isxref blk) :vlax-false)
            ) ;_ end of and
     (progn
       (vlax-for subent blk
         (if (/= (vla-get-ObjectName subent) "AcDbHatch")
           (progn
             (vla-put-layer subent "0")
             (vla-put-color subent 0)
             (vla-put-lineweight subent aclnwtbyblock)
             (vla-put-linetype subent "byblock")
           );_ end of progn
         );_ end of if
       ) ;_ end of vlax-for
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of vlax-for
 (func_restore-layers)
 (vla-endundomark adoc)
 (princ)
) ;_ end of defun

Gilles Chanteau - gileCAD -
Développements sur mesure pour AutoCAD
ADSK_Expert_Elite_Icon_S_Color_Blk_125.png

Lien vers le commentaire
Partager sur d’autres sites

Bonjour,

 

Je m'excuse d’insister après plusieurs essais infructueux je n'arrive pas à faire la même chose sur ce code.

Objectif tout mettre dans la couleur ducalque sauf les hachures.

Je ne sait pas ou placer cette ligne" (if (/= (vla-get-ObjectName subent) "AcDbHatch")"

Cela doit demander une bonne connaissance du langage lisp que je n'ai pas...

 

(defun c:test (/ doc ods)
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 ;;fix all dimstyles
 (setq ods (getvar "dimstyle"))
 (vlax-for d (vla-get-dimstyles doc)
   (vla-put-activedimstyle doc d)
   (foreach n '("dimclrt" "dimclrd" "dimclre")
     (setvar n 256)
   )
   (vla-copyfrom d doc)
 )
 ;;need more code to fix mleader styles, and table styles.  Consider stripmtext by others.
				;.........
 ;;fix all objects (does not include mtext color encoding)
 (vlax-for b (vla-get-blocks doc)
   (if	(= (vla-get-isxref B) :vlax-false)
     (vlax-for	n b
(if (wcmatch (vla-get-objectname n) "*Dim*")
  (vla-put-stylename n (vla-get-stylename n))
  (vl-catch-all-apply 'vla-put-color (list n 256))
))))
 (setvar "dimstyle" ods)
 (vla-regen doc acallviewports)
)

 

Merci

Zara

Lien vers le commentaire
Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité