pascal19

bonjour j'ai eu une manip similaire à faire sur plusieurs fichier j'ai donc fait le script utilisant: WP2PL pour transformer le nettoyer en polyligne ;; WO2PL (gile) ;; Recrée le contour des wipeouts (lwpolyline) (defun c:wo2pl (/ ss n wo elst pts norm) (if (setq ss (ssget '((0 . "WIPEOUT")))) (repeat (setq n (sslength ss)) (setq wo (ssname ss (setq n (1- n))) elst (entget wo) norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst)))) pts (wipeout2plst wo) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length pts)) (cons 38 (caddr (trans (car pts) 0 norm))) '(70 . 1) (cons 210 norm) ) (mapcar '(lambda (pt) (setq pt (trans pt 0 norm)) (list 10 (car pt) (cadr pt)) ) pts ) ) ) ) ) (princ) ) ;;Wipeout2Plst (gile) ;; Retourne la liste des sommets du wipeout (coordonnées SCG) (defun wipeout2plst (wo / elst u v mat) (setq elst (entget wo) u (cdr (assoc 11 elst)) v (cdr (assoc 12 elst)) mat (list u (mapcar '- v) '(0. 0. 1.)) ) (mapcar '(lambda (p) (mapcar '+ (mxv (trp mat) p) (mapcar '(lambda (x y) (/ (+ x y) 2.)) u v) (cdr (assoc 10 elst)) ) ) (cdr (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst) ) ) ) ) ;; V^V (gile) ;; Retourne le produit vectoriel (vecteur) de deux vecteurs (defun v^v (v1 v2) (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2))) (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2))) (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2))) ) ) ;; VUNIT ;; Retourne le vecteur unitaire d'un vecteur (defun vunit (v) ((lambda (l) (if (/= 0 l) (mapcar (function (lambda (x) (/ x l))) v) ) ) (distance '(0 0 0) v) ) ) ;; Transpose a matrix Doug Wilson (defun trp (m) (apply 'mapcar (cons 'list m)) ) ;; Apply a transformation matrix to a vector by Vladimir Nesterovsky (defun mxv (m v) (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m) ) puis ssof pour selectionner et effacer tout à l'interieur de la polyligne ;;; SSOF pour sélectionner tous les objets contenus, suivant ;;; la vue, dans le cercle, l'ellipse ou la polyligne. (defun c:ssof (/ ss opt) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) ) (and (sssetfirst nil nil) (setq ss (ssget "_:S:E" (list '(-4 . " '(0 . "CIRCLE") '(-4 . " '(0 . "ELLIPSE") '(41 . 0.0) (cons 42 (* 2 pi)) '(-4 . "AND>") '(-4 . " '(0 . "LWPOLYLINE") '(-4 . "&") '(70 . 1) '(-4 . "AND>") '(0 . "WIPEOUT") '(-4 . "OR>") ) ) ) ) ) (sssetfirst nil (SelByObj (ssname ss 0) "Wp" nil) ) ) (princ) ) ;;;===============================================================;;; et enfin extrim (commande express) pour ajuster tout avec la polyligne comme seuil cordialement ps merci à gile pour les deux lisp

j'utilise ce programme pour passer tous les wipeout en 255 (j'ai eu le même problème) (defun c:modifim() (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbWipeout") (vla-put-Color ent 255) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport) ) ça marche même pour les wipeout contenus dans les blocs a+

j'ai fini ma petite routine, je crois que ça marche! (defun c:rpint() (setq chint (atof (substr(getvar "dwgname") 2 1))) (if (= chint 8.0) (setq pint '(658800.0 84650.0)) (setq pint '(658750.0 84650.0)) ) ) merci bonuscad pour le coup de main

zut je l'avais presque, j'avais loupé la longueur ( 1 ) par contre mon résultat est une chaine, je peux l'utiliser comme condition: (if (= résultat "1") ... ?

mes fichiers s'appellent 01xxxxxx.dwg 02xxxxxx.dwg ... je voudrais poser une condition sur le deuxième caractère du nom (ici 1 ou 2).

Bonjour Comment puis je transformer dwgname en liste afin d'utiliser le deuxième élément de cette liste dans une routine ?

Merci c'est exactement ce qu'il me fallait, c'est bizard que la recherche cadxp ne me l'ai pas trouvé... dans mon script j'avais contourné le problème en faisant une hachure à partir de mon wipeout et je recréais ma polyligne à partir de hatchb.lsp, pas simple! donc maintenant je peux effacer les objets à l'interieur de mon wipeout avec une routine du genre: wipeout c a wo2pl (je n'ai qu'un wipeout par plan) ssof ((entlast) ne marche pas, peut être p... sinon je déplace avec (entlast) et je redéplace avec p comme ça p marche) effacer je peux ensuite ajuster les objets à l'interieur grace à extrim mais je dois trouver une solution pour automatiser la saisie du point à l'interieur de ma polyligne. je vais rechercher le lisp cookiecutter pour voir... pour situer l'importance de mon besoin, j'ai plus de 1200 fichiers à traiter alors encore un grand merci à gile.

Bonjour dans ma routine de nettoyage de plans j'utilise cette routine pour passer toutes les hachures en couleur 254: (defun modifh2 () (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbHatch") (vla-put-Color ent 254) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport ) ) il me semble ça pourait t'aider a+

bonjour je cherche à transformer un cadre de wipeout en polyligne ou une variante de ssof qui prendrait les wipeout merci de votre aide

en effet, c'est beaucoup mieux et en plus ça marche! merci beaucoup mais savez vous où etait mon erreur (par curiosité)

Bonjour Je cherche à sélectionner les blocs à attributs à partir d'une sélection de bloc, j'ai fait: (defun C:selblatt () (setq sel1 (ssget)) (setq compteur 0) (setq longsel1 (sslength sel1)) (while (< compteur longsel1) (setq entite (ssname sel1 compteur)) (setq blatt (cdr (assoc 66 (entget entite)))) (if (= blatt nil) (ssdel entite sel1) ) (setq compteur (1+ compteur)) ) ) mais ça marche pas, qu'est ce que j'ai oublié encore !?

Bonjour il me semble avoir déja eu ce genre de problème mais être arrivé à la même solution que toi à savoir faire plusieurs contours . sur le coup il m'a semblé qu'autocad avait du mal à gérer des contours dont les sommets étaient trop nombreux et/ou trop proches les uns des autres, il me semble même que sur une hachure, il m'avait suffit de regrouper deux sommets trés proches l'un de l'autre pour que la hachure fonctionne... a noter aussi que l'éloignement du 0,0 peut provoquer des résultats inattendus... a+

Bonjour Je fais toujours évoluer ma routine de nettoyage Suite aux différents tests, il arrive parfois que des sous programmes bugs, et le programme s'arrête, y a t il une solution pour éviter ce problème ci dessous un descriptif ainsi que le code: Paut.lsp : • Descriptif : 1. Règle les variables ANGDIR INSUNITS ANGBASE PLINEGEN à 0 2. contrôle le plan 3. Dévérouille tous les calques 4. "-modiflistechelle" "r" "o" "q" 5. rb2 : met tous les blocs en couleur dubloc dans le calque 0 6. nico2 : efface les textes nuls 7. supcot2 : supprime les cotes 8. tl2-2 : force les types de ligne(supprime DUCALQUE) (même dans les blocs) 9. Crée le calque 0-archi-xx-xx-xx et place tous les objets dégelés sur celui-ci et en couleur DUCALQUE. 10. tlsimplex2 : passe la police de tous les styles de texte en « simplex » 11. supmt2 : supprime les polices forcés dans les textmult (même dans les blocs) 12. Renomme le style de texte standard en « txt-archi » 13. Efface tout ce qui est gelé 14. Recrée un style de texte « standard » en police « arial » 15. modifh2 : passe toutes les hachures en couleur 254 (même dans les blocs) 16. poly0 : passe les largeur de polyligne à 0 (même dans les blocs) 17. zombie2 : Supprime les « acad proxy entity » 18. AttsyncAll : synchronise tous les blocs 19. modifim2 : change couleur des wipeout en 254 (même dans les blocs) 20. Purge (et purge r) • procédure pour purger les plans 1. Détacher tous les XREF 2. Supprimer les présentations 3. geler les calques inutiles (attention les objets en seront supprimés) 4. Lancer la commande PAUT (après l’avoir chargée !) 5. Renommer le calque 0-archi-xx-xx-xx avec la date de réception du plan archi 6. « Enregistrer sous » pour garder le plan archi original Attention, cette procédure n’inclus pas la mise à la bonne échelle du plan ni un changement éventuel d’orientation du plan. Les échelles de type de ligne peuvent aussi poser des problèmes que l’on peut résoudre à l’aide d’un fichier norme (dws). (defun c:paut () (SETVAR "INSUNITS" 0) (SETVAR "angdir" 0) (SETVAR "ANGBASE" 0) (SETVAR "PLINEGEN" 0) (command "controle" "o") (COMMAND "-calque" "D" "*" "") (COMMAND "-modiflistechelle" "r" "o" "q") (rb2) (nico2) (supcot2) (tl2-2) (command "-calque" "n" "0-archi-xx-xx-xx" "co" "252" "0-archi-xx-xx-xx" "" ) (command "changer" "tout" "" "p" "ca" "0-archi-xx-xx-xx" "") (command "changer" "tout" "" "p" "co" "ducalque" "") (tlsimplex2) (supmt2) (command "-renommer" "st" "standard" "txt-archi") (COMMAND "-calque" "L" "*" "g" "0-archi-xx-xx-xx" "") (command "effacer" "tout" "") (COMMAND "-calque" "L" "0-archi-xx-xx-xx" "e" "0-archi-xx-xx-xx" "" ) (command "-style" "standard" "arial.ttf" "0.0" "1.0" "0.0" "n" "n") ;(command "DEPLACER" "tout" "" "0,0" "0,0,1e99") ;(command "DEPLACER" "tout" "" "0,0,1e99" "0,0,0") (modifh2) (poly0-2) (zombie2) (AttSyncAll) (modifim2) (command "-purger" "to" "*" "n") (command "-purger" "r" "*" "n") ) ;******************passe les styles de texte en simplex*************** (defun tlsimplex2 (/ doc) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-for ts (vla-get-TextStyles doc) (if (zerop (logand 1 (cdr (assoc 70 (entget (tblobjname "STYLE" (vla-get-Name ts)))) ) ) ) (vla-put-FontFile ts "simplex.shx") ) ) (vla-regen doc acAllViewports) (princ) ) ;*************************force les types de ligne********************************* (defun tl2-2 () (setq echoold (getvar "cmdecho")) (setvar "cmdecho" 0) ;(command "-calque" "a" "e" "Normalise" "" "" "") (COMMAND "-calque" "D" "*" "") ;(COMMAND "-calque" "L" "*" "AC" "*" "D" "*" "") (COMMAND "-calque" "E" "0" "") ;Normalisation des blocs dans la table des blocs (if (/= nil (setq i (tblnext "block" t))) (progn (setq tot 1) (while i (setq n (cdr (assoc -2 i))) ; SELECTIONNE LA PREMIERE ENTITE QUI COMPOSE LE BLOC (while n (setq n (entget n)) (setq tlorigin (cdr (assoc 6 n))) (if (or (= nil tlorigin) (= 256 tlorigin) (= "BYLAYER" tlorigin) ) (setq tlorigin (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 n)))) ) ) ) ;Récupère le type de ligne de l'entité d'origine (ou de son calque si le type de ligne est "bylayer") (if (not (assoc 6 n)) (setq n (append n (list (cons 6 tlorigin)))) ) ;CHANGE le type de ligne en type de ligne d'origine (setq n (subst (cons 6 tlorigin) (assoc 62 n) n)) (entmod n) (setq n (entnext (cdr (assoc -1 n)))) ;ENTITE SUIVANTE ) ;_ Fin de while (setq i (tblnext "block") tot (1+ tot) ) ;BLOC SUIVANT ) ;_ Fin de while ) ) (setq n2 (entnext)) (while n2 (setq elst (entget n2)) (setq tlorigin (cdr (assoc 6 elst))) (if (or (= nil tlorigin) (= 256 tlorigin) (= "BYLAYER" tlorigin) ) (setq tlorigin (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 elst)))) ) ) ) ;Récupère le type de ligne de l'entité d'origine (ou de son calque si le type de ligne est "bylayer") (if (not (assoc 6 elst)) (setq elst (append elst (list (cons 6 tlorigin)))) ) ;CHANGE le type de ligne en type de ligne d'origine (setq elst (subst (cons 6 tlorigin) (assoc 62 elst) elst)) (entmod elst) (setq n2 (entnext n2)) ;ENTITE SUIVANTE ) ;fin du while ) ;**************************supprime les polices forcées dans mtext******************************* (defun supmt2 (/ ss n txt e_lst str start end lst) ;;;(while (not (setq ss (ssget '((0 . "MTEXT")))))) (if (setq ss (ssget "_X" '((0 . "MTEXT")))) (progn (repeat (setq n (sslength ss)) (setq txt (ssname ss (setq n (1- n))) e_lst (entget txt) str (apply 'strcat (mapcar 'cdr (append (vl-remove-if-not '(lambda (x) (= (car x) 3)) e_lst) (list (assoc 1 e_lst)) ) ) ) ) (while (setq start (vl-string-search "{\\" str)) (setq str (vl-string-subst "" "{" (vl-string-subst "" "}" str start) start ) ) ) (setq start 0) (while (setq start (vl-string-search "\\" str start)) (cond ((= "\\P" (substr str (1+ start) 2)) (setq start (1+ start) end (1+ start) ) ) ((= "\\L" (substr str (1+ start) 2)) (setq end (+ (vl-string-search "L" str start) 2)) ) ((= "\\l" (substr str (1+ start) 2)) (setq end (+ (vl-string-search "l" str start) 2)) ) (T (setq end (+ (vl-string-search ";" str start) 2))) ) (setq str (vl-string-subst "" (substr str (1+ start) (- end start 1)) str ) ) ) (setq lst nil) (if (< 250 (strlen str)) (progn (while (< 249 (strlen str)) (setq lst (cons (cons 3 (substr str 1 250)) lst) str (substr str 251) ) ) (setq lst (reverse (cons (cons 1 str) lst))) ) (setq lst (cons (cons 1 str) lst)) ) (setq e_lst (append (vl-remove-if '(lambda (x) (or (= (car x) 3) (= (car x) 1))) e_lst ) lst ) ) (entmod e_lst) ) (princ) ) ) ) ;**********************change couleur des hachures même dans les blocs************************** (defun modifh2 () (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbHatch") (vla-put-Color ent 254) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport ) ) ;**********************change couleur des wipeout même dans les blocs************************** (defun modifim2 () (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbWipeout") (vla-put-Color ent 255) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport ) ) ;*********************largeurs polylignes 0************************* ;(defun poly0-2 (/ doc) ;(vl-load-com) ;(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;(vlax-for b (vla-get-Blocks doc) ;(if (not (wcmatch (vla-get-name b) "`**_Space*")) ;(vlax-for o b ;(if (vlax-property-available-p o 'ConstantWidth) ;(vla-put-ConstantWidth o 0.0) ;) ;) ;) ;) ;(vla-regen doc acAllViewports) ;(princ) ;) (defun poly0-2 () (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ) (vlax-for bl a (vlax-for ent bl (if (and (vl-string-search "AcDb" (vla-get-objectname ent)) (vl-string-search "Polyline" (vla-get-objectname ent)) ) (vla-put-ConstantWidth ent 0) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport ) ) ;********************suppressions cotes************************* (defun supcot2 () (if (/= nil (setq nom (entnext))) (setq entitytyp (cdr (assoc 0 (entget (setq nom (entnext)))))) ) (while nom (if (= "DIMENSION" entitytyp) (entdel nom) ) (if (/= nil (setq nom (entnext nom))) (setq entitytyp (cdr (assoc 0 (entget nom)))) ) ) ;_ Fin de while (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) ) (vlax-for bl a (vlax-for ent bl (if (and (vl-string-search "AcDb" (vla-get-objectname ent)) (vl-string-search "Dimension" (vla-get-objectname ent)) ) (vla-delete ent) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport ) ) ;*********************efface textes nuls******************* (defun nico2 (/ ss) (if (setq ss (ssget "_X" '((0 . "*TEXT") (1 . " ,")))) (mapcar '(lambda (x) (entdel (cadr x))) (ssnamex ss)) ) ) ;********************blocs couleur dubloc calque 0************************* (defun rb2 (/ a b) (vl-load-com) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)) ) (setq a (tblnext "block" t)) (while a (setq b (cdr (assoc -2 a))) (while b (setq b (entget b)) (if (cdr (assoc 6 b)) (setq b (subst (cons 6 "ByBlock") (assoc 6 b) b)) (setq b (append b (list (cons 6 "ByBlock")))) ) (setq b (subst (cons 8 "0") (assoc 8 b) b)) (if (cdr (assoc 62 b)) (setq b (subst (cons 62 0) (assoc 62 b) b)) (setq b (append b (list (cons 62 0)))) ) (if (cdr (assoc 370 b)) (setq b (subst (cons 370 -2) (assoc 370 b) b)) (setq b (append b (list (cons 370 -2)))) ) (entmod b) (setq b (entnext (cdr (assoc -1 b)))) ) (setq a (tblnext "block")) ) (if (setq a (vl-remove-if-not '(lambda (x) (eq (car x) 350)) (dictsearch (namedobjdict) "ACAD_MLINESTYLE") ) ) (foreach b a (entmod (append (vl-remove-if '(lambda (x) (eq (car x) 62)) (entget (cdr b)) ) (list (cons 62 0) (cons 62 0) (cons 62 0)) ) ) ) ) (if (setq a (ssget "x" (list (cons 0 "INSERT")))) (foreach b (mapcar 'cadr (ssnamex a)) (if (cdr (assoc 66 (entget b))) (progn (setq a (entget (entnext b))) (while (not (eq (cdr (assoc 0 a)) "SEQEND")) (entmod (subst (cons 62 0) (assoc 62 a) a)) (setq a (entget (entnext (cdr (assoc -1 a))))) ) ) ) (entupd b) ) ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)) ) (princ) ) ;********************proxyentities************************* (defun zombie2 () (vlax-for bloc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object) ) ) (vlax-for ent bloc (if (= "AcDbZombieEntity" (vla-get-ObjectName ent)) (vla-delete ent) ) ) ) ) ;********************synchronisation des blocs************************* (defun AttSyncAll (/ blk lst ss ent) (while (setq blk (tblnext "BLOCK" (not blk))) (setq lst (cons (cdr (assoc 2 blk)) lst)) ) (foreach name lst (if (setq ss (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 name))) ) (command "_.attsync" "_name" name) ) ) (princ) )

bonjour synchroniser les blocs permet de mettre à jour les attributs. Dans mon cas j'ai une routine pour nettoyer mes plans architecte dans cette routine j'ai intégré le programme "RB" de patrick35 mon problème est que si je ne synchronise pas tous les blocs il peut rester des calques non purgeables pouvant être contenus dans les attributs. voila le pourquoi du comment...

ok attsync ça me va, en plus je vais pouvoir integrer la routine à gile dans mon programme... merci à tous les trois a+

Bonjour Existe-t-il une routine qui permette de synchroniser tous les blocs d'un coup? merci

désolé il n'y a pas de problème... a+

Bonjour J'ai juste un problème avec mes LISP, en commande, ils marchent trés bien, mais utilisés comme sous-programme , ils ne remplissent leur rôle que dans les blocs ! donc seules les hachures contenues dans les blocs passent en 254 mais pas les autres si quelqu'un avait une idée...

En fait pour les images j'ai fait ça: (defun c:modifim() (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbWipeout") (vla-put-Color ent 255) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport) ) notez que ce dont j'avais besoin c'était changer la couleur des wipeout dans les blocs ce qui me permet d'éviter les problèmes d'impression des pdf (blocs tout noirs) merci à tous ceux qui font vivre ce forum et en particulier à gile (auteur du code source) et à zebulon_ grace à qui j'ai trouvé mes infos

ouai! je suis ceinture marron! trop content!

ça marche : (defun c:modifh() (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbHatch") (vla-put-Color ent 254) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport) ) pour les hachures c'est bon, par contre je cherche pour les images...

peut-être un (vla-put-Color ent 254) je vais essayer...

Bonjour En fait il me semble que ce dont j'ai besoin, c'est de remplacer (vla-delete ent) par une commande qui change la couleur mais existe-t-elle? A+

Merci mais je voudrai integrer ces sélections dans une routine (nettoyage de plans architecte) c'est vrai que je n'utilise pas filter mais je sais que la sélection rapide sur les hachures ne sélectionne pas les hachures contenu dans les blocs...

Bonjour J'utilise actuellement la routine suivante pour supprimer les hachures d'un plan (defun suph2 () (vl-load-com) (setq a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for bl a (vlax-for ent bl (if (= (vla-get-objectname ent) "AcDbHatch") (vla-delete ent) ) ) ) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewport) ) Je voudrai le modifier pour passer les hachures en couleur 254 au lieu de les supprimer Je cherche également une routine similaire pour passer toutes les images raster en couleur 255 (même dans les blocs) D'avance merci