nettoyer toujours nettoyer

pascal19 · le 30 mai 2009

bonjour à tous

Comme beaucoup d'entre vous, je dois nettoyer des plans (architecte) pour un meilleur confort

d'utilisation et un rendu impeccable.

Il semble que chacun ai ses habitudes et que, par conséquent, nous n'ayons pas tous le même

résultat.

Al la base ma méthode consistait à tout exploser virer cotes et hachure et tout coloriser en gris sur un seul calque et passer tous les textes en simplex (sur un style de texte unique).

Et puis j'ai découvert EDIT BLOC , super code de GILE (là on dirait une pub de lessive* !) qui me permettait de conserver les blocs et laisser au plan son orientation "objet" me parait fondamental.

Oui mais voilà, il me manque 2 petites choses pour arriver à mes fins:

- gerer le style de texte pour les textes mtextes attributs à l'interieur des blocs

- gerer la couleur et/ou la suppression des hachures à l'interieur des blocs

merci d'avance de votre aide ou de vos remarques...

a+

* lessive ... nettoyer ... humour! ok je sors!

rebcao · le 30 mai 2009

Bonjour,

Je préconise d'utiliser les plans ARCHI en fond de plan en XREF et j'affecte un style de tracé XREF en GRIS...

En partant du principe que le plan est géré correctement au niveau des calques.

Christian

bonuscad · le 30 mai 2009

d'utiliser les plans ARCHI en fond de plan en XREF

Tout à fais d'accord avec cette méthode.

Je pense avoir vu quelque chose à ce sujet, mais vague souvenir....

Il serait bien de pouvoir forcer l'accroche objet au XY et Z à 0 sur les Xrefs seulement.

Si c'est faisable, merci de me rafraichir la mémoire.

Ça y est, j'ai retrouvé; dans les options:

"Remplacer la valeur Z par l'élévation courante"

Ou encore variable OSNAPZ

[Edité le 30/5/2009 par bonuscad]

pascal19 · le 31 mai 2009

OK pour inserer le plan archi en XREF mais je voudrais quand même le nettoyer, car je ne peux pas travailler si il est de toutes les couleurs, s'il contient des hachures solides ou des solides et si les textes sont en arial.Mais je suis d'accord pour admettre que ce besoin est lié à nos habitudes de travail...

LUDWIG · le 31 mai 2009

Regardes ce post récent, il donne un lien vers le programme de Sechanbask : http://www.cadxp.com/sujetXForum-24012.htm

Sinon, mes lisps (enfin, ma biblio plutôt, la plupart ne sont pas les miens)

;NORMALISER BLOCS
;Place les entités constituant chaque blocs sur le calque 0 en couleur DuBloc

(defun c:nb (/ i n tot)

 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)

 ;(command "-calque" "a" "e" "Normalise" "" "" "")

 (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
; RECHERCHE LA PREMIERE ENTREE DANS LA TABLE DES BLOCS 
(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))
; RECUPERE LES VALEURS DES ENTITES QUI COMPOSE LE BLOC
     (if (/= (cdr (assoc 8 n)) "0")
(progn
  (setq n (subst (cons 8 "0") (assoc 8 n) n))
;SI L'ENTITE N'EST PAS SUR 0, LA DEPLACE SUR 0
  (entmod n)
  ) ;_ Fin de progn
) ;_ Fin de if

     (if (not (assoc 62 n))
;SI L'ENTITE N'A PAS LE CODE DXF 62 (=DuCalque), LE CREE ET LUI AFFECTE LA VALEUR 0 (=DuBloc)
(setq n (append n (list (cons 62 0)))))
(if (/= (cdr (assoc 62 n)) 0)
;SI L'ENTITE N'EST PAS DE COULEUR 0, LA CHANGE EN 0 (=DuBloc)
  (setq n (subst (cons 62 0) (assoc 62 n) n))
  ) ;_ Fin de if

     (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

;Normalisation des étiquettes d'attributs de blocs dans le dessin (car une étiquette peut avoir des valeurs de calque, couleur, etc. différentes de l'attribut)
 (setq sel (ssget "x" (list (cons 0 "INSERT"))))
 (setq j 0)
 (setq nat 0)
 (while (ssname sel j)
   (setq n (entget (ssname sel j)))
   (if	(assoc 66 n)
     (progn
(setq i (entget (entnext (cdr (assoc -1 n)))))
(while (/= (cdr (assoc 0 i)) "SEQEND")
  (setq i (subst (cons 8 "0") (assoc 8 i) i))
; mettre l'attribut sur le calque 0



(if (not (assoc 62 i))(setq i (append i (list (cons 62 0)))))
(if (/= (cdr (assoc 62 i)) 0)(setq i (subst (cons 62 0) (assoc 62 i) i)))
  

  
; mettre l'attribut en couleur dubloc





  
  (entmod i) ; modifier l'entité
  (entupd (cdr (assoc -1 i)))
; mettre à jour sur l'écran l'entité
  (setq nat (+ 1 nat))
  (setq i (entget (entnext (cdr (assoc -1 i)))))
  ) ;_ Fin de while
) ;_ Fin de progn
     ) ;_ Fin de if
   (setq j (1+ j))
   ) ;_ Fin de while

;Résultat
;-----------------------------------------------
 (princ
   (strcat "\nTraitement de "
    (itoa (+ tot nat))
    " bloc(s) ("
    (itoa tot)
    " dans la table des blocs et "
    (itoa nat)
    " étiquette(s) d'attribut(s) de bloc(s) dans le dessin)"
    ) ;_ Fin de strcat
   ) ;_ Fin de princ
 ;(command "-calque" "a" "s" "Normalise" "" "")
 (command "regen")
 (setvar "cmdecho" echoold)
 (graphscr)
 (princ)
   )
 ) 
);_ Fin de defun
(prompt
 "\nnb : Normaliser les blocs du dessin (calque 0 - Couleur Dubloc)"
 ) ;_ Fin de prompt

; supprime le formatage forcé des mtext


(defun c:supmt (/ 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)
)

))

;Supprimer les hachures (même dans les blocs)

(defun c:suph ()
(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)
)

pascal19 · le 3 juin 2009

Bonjour et merci pour vos réponses

LUDWIG: merci pour ta biblio, c'est ce qui semble me convenir le mieux, notamment suph

qui me permet de virer les hachures sans exploser les blocs.

toujours dans le même but, je voudrai pouvoir gerer les polices des textes, textmult et attributs

à l'interieur des blocs,as-tu vu passer quelque chose dans le genre ou sais tu comment y arriver?

Est-ce que "supmt" marche sur les textmult contenus dans les blocs?

Existe-t-il un programme qui passe tous les objets qui sont en type de liqne "ducalque" en type de ligne forcé en fonction de calque de chaque objet? par exemple une ligne sur un calque poutre a pour type de ligne "ducalque", le calque poutre a pour type de ligne "cache" je voudrais que le programme donne à la ligne le type de ligne "cache...

a+

LUDWIG · le 3 juin 2009

J'insiste quand même sur le conseil d'utiliser le programme de sechanbask...

toujours dans le même but, je voudrai pouvoir gerer les polices des textes, textmult et attributs
à l'interieur des blocs,as-tu vu passer quelque chose dans le genre ou sais tu comment y arriver
Est-ce que "supmt" marche sur les textmult contenus dans les blocs?

Je pense que supmt va supprimer le formatage forcé des textes mêmes dans les blocs, à tester. Ensuite, change la police de chaque style de texte.

Existe-t-il un programme qui passe tous les objets qui sont en type de liqne "ducalque" en type de ligne forcé en fonction de calque de chaque objet? par exemple une ligne sur un calque poutre a pour type de ligne "ducalque", le calque poutre a pour type de ligne "cache" je voudrais que le programme donne à la ligne le type de ligne "cache...

J'avais un lisp qui changeait les entités dans les blocs de la couleur "ducalque" à une couleur forcée suivant la couleur du calque d'origine, puis les plaçait sur le calque 0. Il "suffirait" de le modifier un peu (ne pas traiter que dans les blocs, et pas le code dxf de la couleur mais celui du type de ligne). Mais là ça fait trop longtemps que je ne fais plus de lisp pour pouvoir t'aider

(defun c:nb2 ()


 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)

 ;(command "-calque" "a" "e" "Normalise" "" "" "")

 (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
; RECHERCHE LA PREMIERE ENTREE DANS LA TABLE DES BLOCS 
(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 colorigin (cdr (assoc 62 n)))
     (if (or (= nil colorigin)(= 256 colorigin)(= "BYLAYER" colorigin))(setq colorigin (cdr(assoc 62 (tblsearch "layer" (cdr (assoc 8 n)))))))
     (if (> 0 colorigin)(setq colorigin (- 0 colorigin)))
;Récupère la couleur de l'entité d'origine (ou de son calque si la couleur est "bylayer")

     
; RECUPERE LES VALEURS DES ENTITES QUI COMPOSE LE BLOC
     (if (/= (cdr (assoc 8 n)) "0")
(progn
  (setq n (subst (cons 8 "0") (assoc 8 n) n))
;SI L'ENTITE N'EST PAS SUR 0, LA DEPLACE SUR 0
  (entmod n)
  ) ;_ Fin de progn
) ;_ Fin de if

     (if (not (assoc 62 n))
;SI L'ENTITE N'A PAS LE CODE DXF 62 (=DuCalque), LE CREE ET LUI AFFECTE LA VALEUR de son calque d'origine
(setq n (append n (list (cons 62 colorigin)))))

;CHANGE LA COULEUR EN COULEUR D4ORIGINE
  (setq n (subst (cons 62 colorigin) (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

;Normalisation des étiquettes d'attributs de blocs dans le dessin (car une étiquette peut avoir des valeurs de calque, couleur, etc. différentes de l'attribut)
 (setq sel (ssget "x" (list (cons 0 "INSERT"))))
 (setq j 0)
 (setq nat 0)
 (while (ssname sel j)
   (setq n (entget (ssname sel j)))
   (if	(assoc 66 n)
     (progn
(setq i (entget (entnext (cdr (assoc -1 n)))))
(while (/= (cdr (assoc 0 i)) "SEQEND")
  (setq i (subst (cons 8 "0") (assoc 8 i) i))
; mettre l'attribut sur le calque 0



(if (not (assoc 62 i))(setq i (append i (list (cons 62 0)))))
(if (/= (cdr (assoc 62 i)) 0)(setq i (subst (cons 62 0) (assoc 62 i) i)))
  

  
; mettre l'attribut en couleur dubloc





  
  (entmod i) ; modifier l'entité
  (entupd (cdr (assoc -1 i)))
; mettre à jour sur l'écran l'entité
  (setq nat (+ 1 nat))
  (setq i (entget (entnext (cdr (assoc -1 i)))))
  ) ;_ Fin de while
) ;_ Fin de progn
     ) ;_ Fin de if
   (setq j (1+ j))
   ) ;_ Fin de while

;Résultat
;-----------------------------------------------
 (princ
   (strcat "\nTraitement de "
    (itoa (+ tot nat))
    " bloc(s) ("
    (itoa tot)
    " dans la table des blocs et "
    (itoa nat)
    " étiquette(s) d'attribut(s) de bloc(s) dans le dessin)"
    ) ;_ Fin de strcat
   ) ;_ Fin de princ
 ;(command "-calque" "a" "s" "Normalise" "" "")
 (command "regen")
 (setvar "cmdecho" echoold)
 (graphscr)
 (princ)
   )
 ) 
)

pascal19 · le 6 juin 2009

Merci ludwig je vais essayer d'adapter ce code à mes besoins...

supmt marche bien dans les blocs et c'est tant mieux!

Pour les styles de texte, il y en a parfois beaucoup, je vais lancer un post dans routines LISP

au cas où...

a+

pascal19 · le 10 juin 2009

Bonjour

Dans le cadre de mon long et difficile apprentissage (de la peche...) et en signe de bonne volonté, j'ai modifié la routine que m'a fait passé LUDWIG:

(defun c:tl2 ()


 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)

 ;(command "-calque" "a" "e" "Normalise" "" "" "")

 (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
; RECHERCHE LA PREMIERE ENTREE DANS LA TABLE DES BLOCS 
(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

  )
   
 ) 
)

C'est surement pas parfait car j'ai même pas tout compris alors n'hésitez pas à me signaler

les erreurs

Cette routine marche à l'interieur des blocs, je voudrais l'étendre à tous les objets du plan

mais je ne sais pas lancer la boucle sur tous les objets...

a+

pascal19 · le 10 juin 2009

Pour que ça marche sur tous les objets j'ai tenté:

(setq Props (GetLayerProperties))
  (vlax-for ModelSpaceObject (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
     (setq prop (assoc (vla-get-layer ModelSpaceObject) Props))
     
     (if (= "BYLAYER" (vla-get-Linetype ModelSpaceObject)) (vla-put-Linetype ModelSpaceObject (nth 0 prop)))
  )

avec

 (defun GetLayerProperties (
/ linetype ;prop;
  )
 
     (vlax-for layer (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
     (setq linetype (vla-get-Linetype layer))
     (setq prop (list (list linetype)))
       )
  
)

Mais je sais pas pourquoi ça ne marche pas

je vais me couché...

PS Le code complet dont je me suis inspiré est celui-ci

 
layerToByEntityProps
;;; Par Serge Camiré, 2008-12-18
(defun c:BLTBEP (
/ forceTypeLigne forceCouleur pref prop Props
  )
  ;; Force les propriétés (couleur et type de ligne) à être par objet plutôt que par calque.
  (initget "TypeLigne Couleur 2")
  (setq pref (getkword "\nForcer les propriétés suivante [TypeLigne/Couleur/les 2] : "))
  (setq forceTypeLigne (/= pref "Couleur"))
  (setq forceCouleur (wcmatch pref "Couleur,2"))
  (setq Props (GetLayerProperties))

  (vlax-for ModelSpaceObject (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
    
    (setq Props (GetLayerProperties))
    
     (setq prop (assoc (vla-get-layer ModelSpaceObject) Props))
     (if (and forceCouleur (= 256 (vla-get-Color ModelSpaceObject))) (vla-put-Color ModelSpaceObject (nth 1 prop)))
     (if (and forceTypeLigne (= "BYLAYER" (vla-get-Linetype ModelSpaceObject))) (vla-put-Linetype ModelSpaceObject (nth 2 prop)))
  )
  (princ)
)

(defun GetLayerProperties (
/ name color linetype prop return
  )
  ;; Retourne (list (list nomclaque1 couleur1 typeligne1) (list nomclaque2 couleur2 typeligne2)) ...)
  ;; de tout le dessin.
  (setq return nil)
  (vlax-for layer (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
     (setq name (vla-get-name layer))
     (setq color (vla-get-Color layer))
     (setq linetype (vla-get-Linetype layer))
     (setq prop (list (list name color linetype)))
     (setq return (append return prop))
  )
  return
)
(princ "\nTapez BLTBEP pour forcer les propriétés.")
(princ)

mais je n'arrive pas à le faire marcher pour les types de ligne...

(gile) · le 11 juin 2009

Salut,

L'accès aux objets est un peu différent en "pur AutoLISP" (DXF) et en Visual LISP (COM/ActiveX)

avec AutoLISP, en parcourant la table des blocs avec tblnext on n'obtient que les définitions de blocs (et xrefs). Il faut utiliser entnext pour parcourir les espaces objet et papier.

(setq ent (entnext))
(while ent
 ;;...
 ;; Faire ce qu'il y a à faire
 ;; ...
 (setq ent (entnext ent))
)

avec Visual LISP, les objets Layout (EO et Présentations sont aussi considérés comme des blocs (BlockTableRecord). vlax-for permet donc de boucler sur tous les blocs du document (y compris le *Model_Space et les *Paper_Space) et vlax-for toujours, permet de boucler sut tous les objets de chacun des blocs.

(vlax-for blk (vla-get-Blocks
	(vla-get-ActiveDocument
	  (vlax-get-acad-object)
	)
      )
 (vlax-for obj	blk
   ;; ...
   ;; Faire ce qu'il y a à faire
   ;; ...
 )
)

pascal19 · le 11 juin 2009

bonjour

Alors j'ai rajouté ça ...

(setq n2 (entnext))
(while n2
 (setq tlorigin (cdr (assoc 6 n2)))
 (if (or (= nil tlorigin)
  (= 256 tlorigin)
  (= "BYLAYER" tlorigin)
     )
   (setq
     tlorigin (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 n2)))))
   )
 )
 (if (not (assoc 6 n2))
   (setq n2 (append n2 (list (cons 6 tlorigin))))
 )
 (setq n2 (subst (cons 6 tlorigin) (assoc 62 n2) n2))
 (entmod n2)
 (setq n2 (entnext))			;ENTITE SUIVANTE
)

...mais ça ne marche toujours pas, suis-je loin du but?

(gile) · le 11 juin 2009

Salut,

entnext retourne un nom d'entité (ENAME), pour accéder aux propriétés, il faut faire un entget.

(setq n2 (entnext))
(while n2
 (setq elst (entget n2))
 (setq tlorigin (cdr (assoc 6 n2)))
 ...
 ...
 (setq n2 (entnext n2))
)

PS : j'ai du reformater ton code, il était trop difficile à lire. Utilises tu l'éditeur Visual LISP ?

pascal19 · le 11 juin 2009

voila où j'en suis:

(defun c:tl2 ()


 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)

 ;(command "-calque" "a" "e" "Normalise" "" "" "")

 (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)) ;ENTITE SUIVANTE

     );fin du while

  
)

mais ça ne marche toujours pas: ok pour les blocs, mais pour le reste il semble

qu'il change une entité et aprés il plante (il se bloque jusqu'à ce que je l'interrompe)

J'utilise bien la console VISUAL LISP, j'ai "inspecté" les lignes 1 par une sans erreur

mais quand je sélectionne tout mon code et que je lance "console visual lisp"

j'ai le message suivant:

saisie de la boucle d'arrêt clavier

des idées?

(gile) · le 11 juin 2009

Re,

Première chose, si tu veux avoir de l'aide plus facilement, essaye de présenter un code plus facile à lire.

Dans l'éditeur Visual LISP tu as des outils pour formater (mettre en forme) automatiquement le code. : Ctrl+Alt+F et évite de sauter trop de lignes, le formatage dans CADxp en rajoute systématiquement.

Pour ton problème, d'après ce que je suis arrivé à lire, c'est le dernier appel à while qui entre dans une boucle sans fin.

(entnext) retourne la première entité non effacée dans le dessin (entnext n2) retourne l'entité suivant n2.

Regarde ma réponse précédente.

pascal19 · le 11 juin 2009

Cette fois ça marche, merci beaucoup à gile

voici le code en ayant suivi tes conseils

 (defun c:tl2 ()
 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)
;(command "-calque" "a" "e" "Normalise" "" "" "")
 (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
)

a+

pascal19 · le 25 novembre 2009

Le sujet étant récurant, ci-dessous le programme de nettoyage que nous utilisons

(il y a parfois quelques bugs!) au préalable, je supprime les onglets détache les xref et

lance un edit_bloc pour mettre les blocs en calque 0 et couleur dubloc

Ce programme est composé de nombreux sous-programmes piqués sur ce forum...

merci encore à tous ceux qui partagent leur savoir...

 
(defun c:paut()

 (SETVAR "INSUNITS" 0)
 (SETVAR "angdir" 0)
 (SETVAR "ANGBASE" 0)
 (command "controle" "o")
 (COMMAND "-calque" "D" "*" "")
 (COMMAND "-modiflistechelle" "r" "o" "q")
 (nico2)
 (suph2)
 (supcot2)
 (poly0-2)
 (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 "-purger" "to" "*" "n")
       (command "-purger" "r" "*" "n")
   	(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")
	(SETVAR "PLINEGEN" 0)

 (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)

   )

 )

) 


 )

;******************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)

)



))


;**********************supprime les hachures même dans les blocs**************************

(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)

)

;*********************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)

 )

;********************suppressions textes nuls*************************


(defun nico2 (/ ss)

 (if

   (setq ss (ssget "_X" '((0 . "*TEXT") (1 . " ,"))))

   (mapcar '(lambda (x) (entdel (cadr x))) (ssnamex ss))

 )

)

philous2 · le 25 novembre 2009

Slt Pascal,

J'ai chargé ton lisp en mettant le code "tl2"

Cette fois ça marche, merci beaucoup à gile

voici le code en ayant suivi tes conseils

 (defun c:tl2 ()
 (setq echoold (getvar "cmdecho"))
 (setvar "cmdecho" 0)
;(command "-calque" "a" "e" "Normalise" "" "" "")
 (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
)

a+

et j'ai ça comme message

Commande: _appload tl2.LSP correctement chargé(s)
Commande: tl2
nil

pascal19 · le 25 novembre 2009

Bonjour

Commande: _appload tl2.LSP correctement chargé(s)
Commande: tl2
nil

Cela me parait normal...

Vérifie que tu n'as plus d'objets avec type de ligne "ducalque" (avec sélection rapide)

si tel est le cas, le lisp a fonctionné.

a+

pascal19 · le 18 août 2010

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)
)

Connexion

nettoyer toujours nettoyer

Messages recommandés

pascal19

rebcao

bonuscad

pascal19

LUDWIG

pascal19

LUDWIG

pascal19

pascal19

pascal19

(gile)

pascal19

(gile)

pascal19

(gile)

pascal19

pascal19

philous2

pascal19

pascal19

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante