Transformer régions en poylignes.

[MNT]

Bonjour,

 

c'est un lisp que j'avais trouvé sur le site et malgré plusieurs recherches impossible de remettre la main dessus.

 

Une bonne âme aurait ça en stock ??

 

Bonne année.

 

Ps : Pour moi elle commence bien,carte mère HS et réinstalle compléte c'est la fête :casstet:

 

[Edité le 1/1/2007 par MNT]

[(gile)]

Salut,

 

Tu peux trouver dans ce message une routine (Region2Pline) qui transforme une région en polyligne. Attention toutefois, la région doit être uniquement constituée de ligne et d'arcs et ne pas contenir d'ilots.

Plus loin dans ce sujet, j'ai adopté une autre méthode que je peux essayer d'adapter.

 

Pour utiliser Region2Pline tu peux faire juste (region2pline (car (entsel))).

[(gile)]

Re,

 

Voilà un premier jet, s'il y a des ilots dans les regions ils génèreront autant de polylignes, toujours que des régions formées uniquement de lignes et d'arcs (ou de polylignes).

 

Edit : Ajout d'un contrôle pour éviter une erreur si une région contenant une spline, par exemple était sélectionnée.

 

;;; R2PL -Gilles Chanteau- 01/01/07
;;; Transforme les régions sélectionnées en polylignes.

(defun c:r2pl (/ gile_vl_err	 arcbugle	 acdoc	 space
	 ss	 n	 reg	 norm	 expl	 olst
	 blst	 dlst	 plst	 tlst	 blg	 pline
	)
 (vl-load-com)

;;;***************************************************************;;;

 (defun gile_vl_err (msg)
   (if	(or
  (= msg "Fonction annulée")
  (= msg "quitter / sortir abandon")
)
     (princ)
     (princ (strcat "\nErreur: " msg))
   )
   (vla-EndUndoMark
     (vla-get-ActiveDocument (vlax-get-acad-object))
   )
   (setq *error* m:err
  m:err	nil
   )
   (princ)
 )

;;;***************************************************************;;;

 (defun arcbulge (arc)
   (/ (sin (/ (vla-get-TotalAngle arc) 4))
      (cos (/ (vla-get-TotalAngle arc) 4))
   )
 )

;;;***************************************************************;;;

 (setq	acdoc	(vla-get-ActiveDocument (vlax-get-acad-object))
space	(if (= 1 (getvar "CVPORT"))
	  (vla-get-PaperSpace acdoc)
	  (vla-get-ModelSpace acdoc)
	)
m:err	*error*
*error*	gile_vl_err
 )
 (if (setq ss (ssget '((0 . "REGION"))))
   (progn
     (vla-StartUndoMark acdoc)
     (repeat (setq n (sslength ss))
(setq reg  (vlax-ename->vla-object (ssname ss (setq n (1- n))))
      norm (vlax-get reg 'Normal)
      expl (vlax-invoke reg 'Explode)
)
(if (vl-every '(lambda (x)
		 (or
		   (= (vla-get-ObjectName x) "AcDbLine")
		   (= (vla-get-ObjectName x) "AcDbArc")
		 )
	       )
	      expl
    )
  (progn
    (vla-delete reg)
    (setq olst (mapcar '(lambda	(x)
			  (list	x
				(vlax-get x 'StartPoint)
				(vlax-get x 'EndPoint)
			  )
			)
		       expl
	       )
    )
    (while olst
      (setq blst nil)
      (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
	(setq blst (list (cons 0 (arcbulge (caar olst)))))
      )
      (setq plst (cdar olst)
	    dlst (list (caar olst))
	    olst (cdr olst)
      )
      (while
	(setq
	  tlst
	   (vl-member-if
	     '(lambda (x)
		(or (equal (last plst) (cadr x) 1e-9)
		    (equal (last plst) (caddr x) 1e-9)
		)
	      )
	     olst
	   )
	)
	 (if (equal (last plst) (caddar tlst) 1e-9)
	   (setq blg -1)
	   (setq blg 1)
	 )
	 (if
	   (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
	    (setq
	      blst
	       (cons (cons (1- (length plst))
			   (* blg (arcbulge (caar tlst)))
		     )
		     blst
	       )
	    )
	 )
	 (setq plst (append plst
			    (if	(minusp blg)
			      (list (cadar tlst))
			      (list (caddar tlst))
			    )
		    )
	       dlst (cons (caar tlst) dlst)
	       olst (vl-remove (car tlst) olst)
	 )
      )
      (setq pline
	     (vlax-invoke
	       Space
	       'addLightWeightPolyline
	       (apply 'append
		      (mapcar '(lambda (x)
				 (setq x (trans x 0 Norm))
				 (list (car x) (cadr x))
			       )
			      (reverse (cdr (reverse plst)))
		      )
	       )
	     )
      )
      (vla-put-Closed pline :vlax-true)
      (mapcar
	'(lambda (x) (vla-setBulge pline (car x) (cdr x)))
	blst
      )
      (vla-put-Elevation
	pline
	(caddr (trans (car plst) 0 Norm))
      )
      (vla-put-Normal pline (vlax-3d-point Norm))
      (mapcar 'vla-delete dlst)
    )
  )
  (mapcar 'vla-delete expl)
)
     )
     (vla-EndUndoMark acdoc)
   )
 )
 (setq	*error*	m:err
m:err nil
 )
 (princ)
) 

 

[Edité le 1/1/2007 par (gile)]

[MNT]

Merci (gile)

 

à peine le temps de regarder la première solution qu'une deuxième apparaît :D

 

merci beaucoup pour l'ensemble de ton travail

 

@=