Placer toutes entités à Z=0

[DenisHen]

Bonjour à tous.

 

Je sais que le sujet a déjà été traité, mais je n'ai pas trouvé le post.

 

Je cherche à supprimer tous ce qui peut être à une altitude ou élévation différents de 0.

 

J'ai donc commencé un petit Lisp, mais qui ne fonctionne pas. Le voici :

;;;**************************************************************
;;; Déplacement des entités à l'altitude 0 et les élévations à 0 
;;;**************************************************************
(defun c:Z0 ( / ss i ent elst)
 (princ "\nDéveloppé par Denis H. (vers.1.0)")
 (princ "\nDéplacement des blocs à l'altitude 0 et modifie les élévation à 0.")
 (if (setq ss (ssget "_X"))
   (progn (setq i 0)
          (while (setq ent (ssname ss i))
            (setq i      (1+ i)
                  elst   (entget ent)
            ) ;_ Fin de setq
            (cond ((= (cdr (assoc 0 elst)) "ARC") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "CIRCLE") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "INSERT") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "POINT") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "LWPOLYLINE") (setq elst (subst (cons 38 0.0) (assoc 38 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "TEXT") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
                  ((= (cdr (assoc 0 elst)) "MTEXT") (setq elst (subst (cons 30 0.0) (assoc 30 elst) elst)) (entmod elst))
            ) ;_ Fin de cond
          ) ;_ Fin de while
   ) ;_ Fin de progn
 ) ;_ Fin de if
 (princ)
)

Si quelqu'un a une idée, un conseil... Je suis preneur...

 

Denis.

[x_all]

je ne saurais te débugger ton code, mais je me rappelle d'avoir lu que ce lisp n'était pas trivial...

 

par contre je te rappelle la petite macro à placer dans un bouton qui fait la blague...

 

Attention, se placer en SCG, sauver avant de lancer la macro, vérifier que ça à bien marcher en se mettant en vue de coté.

J'ai déjà flingué un dessin car des calques gelés ont bloqué des entités, du coup tu as des truc à z0 et d'autres à z99e99 et ça fout un bazar indéboulonnable...

 

 

^C^Cucsfollow;0;scu;g;déplacer;tout;;0,0,1e99;;déplacer;tout;;0,0,-1e99;;

[DenisHen]

Salut x_all, et merci pour ton aide.

 

J'ai justement déjà essayé cette macro, mais AutoCAD s'arrêtait d'un coup, j'ai donc "universalisé" cette macro, ce qui donne :

^C^Cucsfollow;0;scu;ge;_move;_all;;0,0,1e99;;_move;_all;;0,0,-1e99;;

Mais ça me change pas les élévations des LWPOLYLIGN... Raison pour laquelle je m'étais penché sur un Lisp...

 

Encore merci pour ton aide.

[DenisHen]

Re.

 

Voici donc un Lisp intégrant la macro de x_all qui supprime aussi les élévations des LWPOLYLIGN :

;;;**************************************************************
;;; Déplacement des entités à l'altitude 0 et les élévations à 0 
;;;**************************************************************
(defun c:Z0 (/ ss i ent elst)
 (princ "\nDéveloppé par Denis H. (vers.1.0)")
 (princ "\nDéplacement des blocs à l'altitude 0 et modifie les élévation à 0.")
 (command "ucsfollow" "0" "scu" "ge" "_move" "_all" "" "" "0,0,1e99" "" "" "_move" "_all" "" "" "0,0,-1e99" "" "") ;_ Fin de command
 (if (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
   (progn (setq i 0)
          (while (setq ent (ssname ss i))
            (setq i    (1+ i)
                  elst (entget ent)
            ) ;_ Fin de setq
            (cond ((= (cdr (assoc 0 elst)) "LWPOLYLINE")
                   (setq elst (subst (cons 38 0.0) (assoc 38 elst) elst))
                   (entmod elst)
                  )
            ) ;_ Fin de cond
          ) ;_ Fin de while
   ) ;_ Fin de progn
 ) ;_ Fin de if
 (princ)
) ;_ Fin de defun

Si ça peut être utile à d'autres...

[(gile)]

Salut,

 

Un truc qui correspond à ton LISP :

 

;;;**************************************************************
;;; Déplacement des entités à l'altitude 0 et les élévations à 0 
;;;**************************************************************
(defun c:Z0 (/ substZ0 ss i ent elst)
 (princ "\nDéveloppé par Denis H. (vers.1.0)")
 (princ "\nDéplacement des blocs à l'altitude 0 et modifie les élévation à 0.")

 (defun substZ0 (key alst / entry)
   (if (setq entry (assoc key alst))
     (subst (reverse (cons 0.0 (cdr (reverse entry)))) entry alst)
     alst
   )
 )

 (if (setq ss (ssget "_X"))
   (progn (setq i 0)
          (while (setq ent (ssname ss i))
            (setq i    (1+ i)
                  elst (entget ent)
            ) ;_ Fin de setq
            (cond
              ((= (cdr (assoc 0 elst)) "LWPOLYLINE") (entmod (subst (cons 38 0.0) (assoc 38 elst) elst)))
              ((= (cdr (assoc 0 elst)) "LINE") (entmod (substZ0 10 (substZ0 11 elst))))
              (T (substZ0 10 elst))
            ) ;_ Fin de cond
          ) ;_ Fin de while
   ) ;_ Fin de progn
 ) ;_ Fin de if
 (princ)
)

 

Mais comme le dit x_all, le processus n'est pas si simple et le LISP ci dessus ne fonctionnera que si les objets 2d (polyligne, cercle, texte, bloc, etc.) ont été dessinés dans un plan parallèle au plan XY.

 

Tu peux essayer d'utiliser la commande FLATTEN des express tools qui projette les objets sur le plan de a vue (se mettre en vue de dessus avant de lancer la commande).

 

Macro (non testée)

^C^C_-view;top;flatten;_all;;no;

 

En LISP, on ne peut pas utiliser la fonction command parce que FLATTEN est une "commande" définie en LISP (defun c:flatten ...), il faut donc utiliser SendCommand pour appeler le lISP et lui passer les arguments

(defun c:Z0 ()
 (vl-load-com)
 (command "_.view" "_top")
 (vla-sendcommand (vla-get-ActiveDocument (vlax-get-acad-object)) "flatten _all  no ")
 (princ)
)

[DenisHen]

Salut (gile), et merci pour ton aide.

 

Je m'étais replongé dans ce lisp suite à une accalmie au boulo, les vacances arrivent.

 

Et une fois de plus, tu as raison, flatten rempli exactement ce que je cherche à faire...

 

Par contre, je reste scotché sur ton defun substZ0...

 

Encore merci...

[lecrabe]

Hello

 

Alors nous avons en stock :

- ALLFLAT de Lee-Mac

- SuperFlatten de Joe Burke

 

Tu peux faire une recherche par GOOGLE avec les bons mots cles et tu trouveras ...

 

ALLFAT & SuperFlatten sont OK dans presque TOUS les cas !

Apres il y a toujours des problemes SUBTILS des que des choses sont dessinees

dans des SCUs non coplanaires au niveau Z=0 du SCG !

 

Par contre je ne les ai pas testes sur des ACADs RECENTS: 2018/2017/2016 !?

 

A tester et nous dire quelle version de ALLFLAT et SuperFlatten, tu as utilise ...

 

Merci, Bye, lecrabe

[DaWeeD_Gab]

Hello,

 

j'ai eu à utiliser SuperFlatten, Version SuperFlatten 1.1 - 8/16/2007, sur Autocad MAP 2018 et ça marche nickel !

[DenisHen]

A tester et nous dire quelle version de ALLFLAT et SuperFlatten, tu as utilise ...

J'ai des besoins très simples, flattent des ExpressTools me suffit amplement...

 

D'autres auront peut-être un retour sur ces routines...

[DenisHen]

Salut à tous.

 

je reviens sur ce sujet mainte fois abordé, mais j'ai un petit problème.

 

J'ai un fichier DWG issus de TopStation. Ce fichiers comporte des centaines de polylignes 3D qui n'ont pas de "Z", bref, de la 3D sans 3D.

 

Je cherche quelque-chose qui pourrait me transformer ces polylignes 3D en polylignes 2D, avec toute l'altimétrie à 0...

 

Si quelqu'un as une solution, une astuce, un conseil... Je suis preneur...

[bonuscad]

Bonsoir Denis

Je l'avais déjà posté, mais je préfère le remettre car il est possible qu'il ai reçu des modifications depuis.

Un développement qui normalement se limite seulement à des entités curvilignes, mais avec une rapidité de traitement supérieur à flatten (qui lui est plus puissant mais plus long)

 

Si tu veux essayer...

(defun l-coor2l-pt (lst flag / )
 (if lst
(cons
 	(list
   	(car lst)
   	(cadr lst)
   	(if flag
     	(+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
     	(if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
   	)
 	)
 	(l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
)
 )
)
(vl-load-com)
(defun c:my_project ( / jspl nbr n AcDoc Space UCS save_ucs WCS ent_name indx l_blg l_pt ename id_obj pl_typ index nw_pl)
(setq
 jspl
  (ssget
'((-4 . "<OR")
	(-4 . "<AND")
 	(0 . "POLYLINE")
 	(-4 . "<NOT")
  	(-4 . "&") (70 . 112)
 	(-4 . "NOT>")
	(-4 . "AND>")
	(0 . "LWPOLYLINE,LINE,SPLINE,ARC,CIRCLE,ELLIPSE,POINT")
(-4 . "OR>"))
  )
 nbr -1
 n 0
)
(cond
 (jspl
(setq
 	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
 	Space
 	(if (eq (getvar "CVPORT") 1)
   	(vla-get-PaperSpace AcDoc)
   	(vla-get-ModelSpace AcDoc)
 	)
 	UCS (vla-get-UserCoordinateSystems AcDoc)
 	save_ucs
 	(vla-add UCS
   	(vlax-3d-point '(0.0 0.0 0.0))
   	(vlax-3d-point (getvar "UCSXDIR"))
   	(vlax-3d-point (getvar "UCSYDIR"))
   	"CURRENT_UCS"
 	)
)
  (vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
  (vla-StartUndoMark AcDoc)
  (setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
  (vla-put-activeUCS AcDoc WCS)
  (repeat (sslength jspl)
(setq
	ent_name (ssname jspl (setq nbr (1+ nbr)))
	indx -1
	l_blg nil
	l_pt nil
	ename (vlax-ename->vla-object ent_name)
	id_obj (vla-get-ObjectName ename)
)
(cond
	((member id_obj '("AcDbPolyline" "AcDb2dPolyline" "AcDb3dPolyline"))
 	(setq pl_typ (if (vlax-property-available-p ename 'Type) (vlax-get ename 'Type)))
 	(if (member id_obj '("AcDbPolyline" "AcDb2dPolyline"))
  	(if (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13))
   	(progn
    	(repeat (fix (vlax-curve-getEndParam ename))
     	(setq l_pt (cons (vlax-curve-GetPointAtParam ename (setq indx (1+ indx))) l_pt) index (float indx))
     	(if (or (eq pl_typ 1) (if (< pl_typ 3) (not (zerop (vla-GetBulge ename indx)))))
      	(while (eq indx (fix (+ 0.01 index)))
       	(setq l_pt (cons (vlax-curve-GetPointAtParam ename (setq index (+ 0.01 index))) l_pt))
      	)
     	)
    	)
    	(setq l_pt (cons (vlax-curve-getEndPoint ename) l_pt))
   	)
   	(setq l_pt
    	(mapcar
     	'(lambda (x)
      	(trans
       	(list
        	(car x)
        	(cadr x)
        	(- ;+
         	(if (eq id_obj "AcDbPolyline") (caddr x) 0.0)
         	(if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
        	)
       	)
       	ent_name
       	0
      	)
     	)
     	(l-coor2l-pt (vlax-get ename 'Coordinates) (eq id_obj "AcDb2dPolyline"))
    	)
   	)
  	)
  	(setq l_pt (l-coor2l-pt (vlax-get ename 'Coordinates) T))
 	)
 	(if (eq (vla-get-ObjectName ename) "AcDbPolyline")
  	(setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt)))))
  	(setq nw_pl (vlax-invoke Space 'AddPolyline (apply 'append l_pt)))
 	)
 	(vla-put-Normal nw_pl (vlax-3d-point '(0 0 1)))
 	(if (vlax-property-available-p ename 'Type)
  	(progn
   	(setq pl_typ
    	(if (eq (vla-get-ObjectName ename) "AcDb3dPolyline")
     	(if (zerop (vlax-get ename 'Type)) (vlax-get ename 'Type) (1+ (vlax-get ename 'Type)))
     	(vlax-get ename 'Type)
    	)
   	)
   	(if (and (vlax-property-available-p ename 'Normal) (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13)) (eq pl_typ 1))
    	(vla-put-Type nw_pl 0)
    	(vla-put-Type nw_pl pl_typ)
   	)
  	)
  	(if (and (vlax-property-available-p ename 'Normal) (equal (vlax-get ename 'Normal) '(0 0 1) 1E-13))
   	(progn
    	(repeat (length l_pt) (setq l_blg (cons (vla-GetBulge ename (setq indx (1+ indx))) l_blg)))
    	(foreach el l_blg (vla-SetBulge nw_pl indx el) (setq indx (1- indx)))
   	)
  	)
 	)
 	(vla-put-Closed nw_pl (vlax-get ename 'Closed))
	)
	((member id_obj '("AcDbEllipse" "AcDbCircle" "AcDbArc"))
 	(if (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13))
  	(progn
   	(setq
    	index (vlax-curve-getStartParam ename)
    	l_pt (list (vlax-curve-GetPointAtParam ename index))
   	)
   	(while (< (setq index (+ 0.01 index)) (vlax-curve-getEndParam ename))
    	(setq l_pt (cons (vlax-curve-GetPointAtParam ename index) l_pt))
   	)
   	(setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt)))))
  	)
  	(cond
   	((eq id_obj "AcDbEllipse")
    	(setq
     	l_pt (vlax-get ename 'Center)
     	nw_pl
     	(vlax-invoke Space 'AddEllipse
      	(list (car l_pt) (cadr l_pt) 0.0)
      	(list (car (vlax-get ename 'MajorAxis)) (cadr (vlax-get ename 'MajorAxis)) 0.0)
      	(* (caddr (vlax-get ename 'Normal)) (vlax-get ename 'RadiusRatio))
     	)
    	)
    	(vla-put-Normal nw_pl (vlax-3d-point '(0 0 1)))
    	(vla-put-StartAngle nw_pl (vlax-get ename 'StartAngle))
    	(vla-put-StartParameter nw_pl (vlax-get ename 'StartParameter))
    	(vla-put-EndParameter nw_pl (vlax-get ename 'EndParameter))
   	)
   	((or (eq id_obj "AcDbArc") (eq id_obj "AcDbCircle"))
    	(setq
     	l_pt (vlax-get ename 'Center)
     	nw_pl
     	(if (eq id_obj "AcDbArc")
      	(vlax-invoke Space 'AddArc (list (car l_pt) (cadr l_pt) 0.0) (vlax-get ename 'Radius) (vlax-get ename 'StartAngle) (vlax-get ename 'EndAngle))
      	(vlax-invoke Space 'AddCircle (list (car l_pt) (cadr l_pt) 0.0) (vlax-get ename 'Radius))
     	)
    	)
    	(vla-put-Normal nw_pl (vlax-3d-point '(0 0 1)))
   	)
  	)
 	)
	)
	((eq id_obj "AcDbSpline")
 	(if
  	(or
   	(zerop (vlax-get ename 'IsPlanar))
   	(and
    	(not (zerop (vlax-get ename 'IsPlanar)))
    	(not (equal (cdr (assoc 210 (entget ent_name))) '(0.0 0.0 1.0) 1E-13))
   	)
  	)
  	(progn
   	(setq
    	index (vlax-curve-getStartParam ename)
    	l_pt (list (vlax-curve-GetPointAtParam ename index))
   	)
   	(while (< (setq index (+ 10.0 index)) (vlax-curve-getEndParam ename))
    	(setq l_pt (cons (vlax-curve-GetPointAtParam ename index) l_pt))
   	)
   	(setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt)))))
  	)
  	(progn
   	(setq
    	l_pt (l-coor2l-pt (if (zerop (vlax-get ename 'NumberOfFitPoints)) (cdddr (reverse (cdddr (reverse (vlax-get ename 'ControlPoints))))) (vlax-get ename 'FitPoints)) T)
    	nw_pl
    	(vlax-invoke Space
     	'AddSpline
     	(apply 'append (mapcar '(lambda (x y) (list x y 0.0)) (mapcar 'car l_pt) (mapcar 'cadr l_pt)))
     	(list (car (vlax-curve-getFirstDeriv ename 0)) (cadr (vlax-curve-getFirstDeriv ename 0)) 0.0)
     	(list (car (vlax-curve-getFirstDeriv ename (vlax-curve-getEndParam ename))) (cadr (vlax-curve-getFirstDeriv ename (vlax-curve-getEndParam ename))) 0.0)
    	)
    	l_pt (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
   	)
   	(vla-put-ControlPoints nw_pl 
    	(vlax-make-variant
     	(vlax-safearray-fill
      	(vlax-make-safearray
       	vlax-vbDouble
       	(cons 0 (1- (* (length l_pt) 3)))
      	)
      	(apply 'append (mapcar '(lambda (x y) (list x y 0.0)) (mapcar 'car l_pt) (mapcar 'cadr l_pt)))
     	)
    	)
   	)
  	)
 	)
	)
	((eq id_obj "AcDbLine")
 	(setq nw_pl
  	(vlax-invoke Space
   	'AddLine
   	(list (car (vlax-get ename 'StartPoint)) (cadr (vlax-get ename 'StartPoint)) 0.0)
   	(list (car (vlax-get ename 'EndPoint)) (cadr (vlax-get ename 'EndPoint)) 0.0)
  	)
 	)
 	(vla-put-Normal nw_pl (vlax-3d-point '(0 0 1)))
	)
	((eq id_obj "AcDbPoint")
 	(setq nw_pl
  	(vlax-invoke Space
   	'AddPoint
   	(list (car (vlax-get ename 'Coordinates)) (cadr (vlax-get ename 'Coordinates)) 0.0)
  	)
 	)
 	(vla-put-Normal nw_pl (vlax-3d-point '(0 0 1)))
	)
)
(vla-put-Layer nw_pl (vla-get-Layer ename))
(vla-delete ename)
  )
  (and save_ucs (vla-put-activeUCS AcDoc save_ucs))
  (and WCS (vla-delete WCS) (setq WCS nil))
  (vla-EndUndoMark AcDoc)
  (princ
(strcat
	"\n"
	(itoa (sslength jspl))
	" entité(s) soumises à la commande. TERMINE !"
)
  )
 )
 (T (princ "\nPas d'entités conformes sélectionnées..!"))
)
(prin1)
)

 

[DenisHen]

Salut bonuscad.

 

J'ai juste deux choses à dire...

 

1. Heureusement que tu est sur CadXP un vendredi soir à presque 23h ! ! !

2. Ton LiSP fonctionne parfaitement... je vais pouvoir avancer dans un dossier de merde que je dois rendre lundi matin...

 

Il y a un petit 3. Encore un grand merci ! ! !

 

Denis...

[bonuscad]

Heureux, si tu peux te coucher plus tôt!

 

Mais à mon avis tu devrais songer à lâcher un peu la bride... Lundi matin est un autre jour!