Joindre 3D polylignes selon calques

[chris_mtp]

Bonjour à tous.

 

Serait il possible à partir du lisp de Gile de, au lieu de sélectionner soi-même les polylignes 3D à joindre, sélectionner de manière automatique tous les polylignes 3D d'un même calque et de les joindre si elles sont jointives sinon non et ceci pour tous les calques d'un dessin autocad ?

 

 

 
;; Join3dPoly (gile)
;; Joint les objets sélectionnés en une polyligne 3d s'ils sont jointifs
;; La polyligne est créée avec les propriétés courantes (calque, couleur, ...)

(defun c:Join3dPoly (/ Space ss lst plst olst n 3p)
 (vl-load-com)
 (or *acdoc*
     (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (setq	Space (if (= (getvar "CVPORT") 1)
	(vla-get-PaperSpace *acdoc*)
	(vla-get-ModelSpace *acdoc*)
      )
 )
 (while (not (ssget '((-4 . "		       (0 . "LINE")
	       (-4 . "		       (0 . "POLYLINE")
	       (70 . 8)
	       (-4 . "AND>")
	       (-4 . "		       (0 . "LWPOLYLINE")
	       (70 . 0)
	       (-4 . "AND>")
	       (-4 . "OR>")
	      )
      )
 )
 )
 (vlax-for obj	(setq ss (vla-get-ActiveSelectionSet *acdoc*))
   (cond
     ((= (vla-get-ObjectName obj) "AcDbLine")
      (setq lst (cons
	   (cons obj
		 (list (vlax-get obj 'StartPoint)
		       (vlax-get obj 'EndPoint)
		 )
	   )
	   lst
	 )
      )
     )
     ((= (vla-get-ObjectName obj) "AcDbPolyline")
      (setq lst (cons (cons obj (PlinePoints obj)) lst))
     )
     ((= (vla-get-ObjectName obj) "AcDb3dPolyline")
      (setq lst
      (cons
	(cons obj (3d-coord->pt-lst (vlax-get obj 'Coordinates)))
	lst
      )
      )
     )
   )
 )
 (while (and lst (< (length olst) 2))
   (setq plst (cdar lst)
  olst (list (caar lst))
  lst  (cdr lst)
  n    0
   )
   (while (and lst (< n (length lst)))
     (cond
((equal (cadar lst) (last plst) 1e-9)
 (setq plst (append plst (cddar lst))
       olst (cons (caar lst) olst)
       lst  (cdr lst)
       n    0
 )
)
((equal (last (cdar lst)) (car plst) 1e-9)
 (setq plst (append (cdar lst) (cdr plst))
       olst (cons (caar lst) olst)
       lst  (cdr lst)
       n    0
 )
)
((equal (cadar lst) (car plst) 1e-9)
 (setq plst (append (reverse (cdar lst)) (cdr plst))
       olst (cons (caar lst) olst)
       lst  (cdr lst)
       n    0
 )
)
((equal (last (cdar lst)) (last plst) 1e-9)
 (setq plst (append plst (cdr (reverse (cdar lst))))
       olst (cons (caar lst) olst)
       lst  (cdr lst)
       n    0
 )
)
(T
 (setq lst (append (cdr lst) (list (car lst)))
       n   (1+ n)
 )
)
     )
   )
 )
 (if (and (= 1 (setq n (length olst))) (< 1 (vla-get-Count ss)))
   (princ "\nObjets non jointifs.")
   (progn
     (vla-StartUndoMark *acdoc*)
     (vlax-invoke Space 'add3dPoly (apply 'append plst))
     (if (= 1 n)
(princ "\n1 objet a été transformé en polyligne 3d.")
(princ (strcat "\n"
	       (itoa n)
	       " objets ont été joints en une polyligne 3d."
       )
)
     )
     (mapcar 'vla-delete olst)
     (vla-EndUndoMark *acdoc*)
   )
 )
 (vla-delete ss)
 (princ)
)

;;; 3d-coord->pt-lst
;;; Convertit une liste de coordonnées 3D en liste de points
;;; (3d-coord->pt-lst '(1.0 2.0 3.0 4.0 5.0 6.0)) -> ((1.0 2.0 3.0) (4.0 5.0 6.0))

(defun 3d-coord->pt-lst	(lst)
 (if lst
   (cons (list (car lst) (cadr lst) (caddr lst))
  (3d-coord->pt-lst (cdddr lst))
   )
 )
)

;;; PlinePoints
;;; Retourne la liste des sommets (coordonnées SCG) de la polyligne (ename ou vla-object)

(defun PlinePoints (pl / sub)
 (vl-load-com)
 (or (= (type pl) 'VLA-OBJECT)
     (setq pl (vlax-ename->vla-object pl))
 )

 (defun sub (l e n)
   (if	l
     (cons (trans (list (car l) (cadr l) e) n 0)
    (sub (cddr l) e n)
     )
   )
 )

 (sub (vlax-get pl 'Coordinates)
      (vla-get-Elevation pl)
      (vlax-get pl 'Normal)
 )
)

 

En effet, j'ai un plan autocad de restitution qui pèse plus de 100Mo avec un nombre de polylignes important et j'aimerais automatiser certaines procédures.

 

Je n'ariive pas non plus à lister moi même la liste des calques d'un dessin autocad avec la fonction getlayer.ou a moins que cette fonction serve à choisir le calque courant..

 

Merci par avance de votre aide.

Chris_mtp

[(gile)]

Salut,

 

Ce que tu demandes n'est pas simple, je verrais ce que je peux faire, mais en attendant, tu peux voir la routine AutoJoin.

[(gile)]

Re,

 

Voilà, je n'ai pas testé en profondeur, mais ça semble marcher

 

(defun c:AutoJoinByLayer (/ *error* lock lst ss pl1 lst1 pt lst2 pl2)
 (vl-load-com)
 (or *acad* (setq *acad* (vlax-get-acad-object)))
 (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
 (or *layers* (setq *layers* (vla-get-Layers *acdoc*)))

 (defun *error* (msg)
   (or	(= msg "Fonction annulée")
(princ (strcat "\nErreur: " msg))
   )
   (vla-ZoomPrevious *acad*)
   (vla-EndUndoMark *acdoc*)
   (princ)
 )

 (vla-StartUndoMark *acdoc*)
 (vla-zoomExtents *acad*)
 (vlax-for lay	*layers*
   (if	(ssget "_X"
       (list '(0 . "POLYLINE")
	     '(70 . 8)
	     (cons 8 (vla-get-Name lay))
       )
)
     (progn
(and (= (vla-get-Lock lay) :vlax-true)
     (setq lock T)
     (vla-put-Lock lay :vlax-false)
)
(setq lst nil)
(vlax-for poly (setq ss (vla-get-ActiveSelectionSet *acdoc*))
  (setq lst (cons poly lst))
)
(vla-delete ss)
(while (cdr lst)
  (setq	pl1  (car lst)
	lst  (cdr lst)
	lst1 (3d-coord->pt-lst (vlax-get pl1 'Coordinates))
	pt   (last lst1)
  )
  (while
    (and
      (or
	(and
	  (setq	ss (ssget "_C"
			  (trans pt 0 1)
			  (trans pt 0 1)
			  (list	'(0 . "POLYLINE")
				'(70 . 8)
				(cons 8 (vla-get-Name lay))
			  )
		   )
	  )
	  (setq ss (ssdel (vlax-vla-object->ename pl1) ss))
	  (= 1 (sslength ss))
	)
	(and
	  (not
	    (vlax-put pl1
		      'Coordinates
		      (apply 'append (setq lst1 (reverse lst1)))
	    )
	  )
	  (setq pt (last lst1))
	  (setq	ss (ssget "_C"
			  (trans pt 0 1)
			  (trans pt 0 1)
			  (list	'(0 . "POLYLINE")
				'(70 . 8)
				(cons 8 (vla-get-Name lay))
			  )
		   )
	  )
	  (setq ss (ssdel (vlax-vla-object->ename pl1) ss))
	  (= 1 (sslength ss))
	)
      )
      (setq pl2 (vlax-ename->vla-object (ssname ss 0)))
      (setq lst2 (3d-coord->pt-lst (vlax-get pl2 'Coordinates)))
      (or (equal pt (car lst2) 1e-9)
	  (and (setq lst2 (reverse lst2))
	       (equal pt (car lst2) 1e-9)
	  )
      )
    )
     (vlax-put
       pl1
       'Coordinates
       (apply 'append (setq lst1 (append lst1 (cdr lst2))))
     )
     (vla-update pl1)
     (setq lst (vl-remove pl2 lst))
     (vla-delete pl2)
     (setq pt (last lst2))
  )
)
(and lock
     (not (setq lock nil))
     (vla-put-Lock lay :vlax-true)
)
     )
   )
 )
 (vla-ZoomPrevious *acad*)
 (vla-EndUndoMark *acdoc*)
 (princ)
) 

[chris_mtp]

Merci Gile pour ce lisp modifie

 

Je l'ai testé dans diverses config comme des poly 2d joint à des poly 3d, des poly 3d non jointives, des poly 3d jointives d'un même calque et appartenant à des calques différents.

Et franchement, il n'y a pas de problème. Le lisp marche à merveille et dans tous les cas de figure.

 

Merci encore qui je pense va rendre service à plus d'un.

 

Chris_mtp.