Extrusion sur chemins multiples

[(gile)]

En réponse à une demande sur un forum américain, j'ai fais ce LISP (à partir de Curve2Pipe sur cette page)).

 

L'utilisateur sélectione le profil à extruder (entité plane et fermée : cercle, ellipse, polyligne, région) et spécifie un point de base.

Puis il sélectionne un ou plusieurs chemins (entités planes : arc, cercle, ellipse, polyligne, spline).

 

Le LISP fonctionne quelques soient les plans qui contiennent le profil et les chemins.

Pour chaque chemin du jeu de sélection, la direction d'extrusion du profil, est alignée avec le vecteur tangent au départ de l'objet servant de chemin.

Si la valeur de la variable DELOBJ est supérieure à 0, le profil et le chemin sont supprimés.

 

;; MEXTRUDE -Gilles Chanteau- (gile) 13/01/2008
;; Extrude le profil suivant les chemins sélectionnés.
;; La direction d'extrusion du profil (normale) est alignée
;; avec le vecteur tangent au départ de chaque chemin

(defun c:mextrude (/ space prof org ss start reg mat norm)

 (vl-load-com)

 (or *acdoc*
     (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (setq	space (if (= 1 (getvar "CVPORT"))
	(vla-get-PaperSpace *acdoc*)
	(vla-get-ModelSpace *acdoc*)
      )
 )
 (if (and (setq prof (car (entsel "\nSelectionnez le profil à extruder: ")))
   (setq prof (vlax-ename->vla-object prof))
   (or
     (= (vla-get-ObjectName prof) "AcDbRegion")
     (and
       (not (vl-catch-all-error-p
	      (setq prof
		     (vl-catch-all-apply
		       'vlax-invoke
		       (list space 'addRegion (list prof))
		     )
	      )
	    )
       )
       (setq prof (car prof))
     )
   )
     )
   (if
     (setq org (trans (getpoint "\nSpécifiez le point de base: ") 1 0))
      (if
 (setq ss (ssget
	    '((-4 . "[b]		      (0 . "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE")
	      (-4 . "[b]		      (0 . "POLYLINE")
	      (-4 . "[b]		      (-4 . "&")
	      (70 . 112)
	      (-4 . "NOT>")
	      (-4 . "AND>")
	      (-4 . "[b]		      (0 . "SPLINE")
	      (-4 . "&")
	      (70 . 8)
	      (-4 . "AND>")
	      (-4 . "OR>")
	     )
	  )
 )
  (progn
    (vla-StartUndoMark *acdoc*)
    (vlax-for obj (vla-get-ActiveSelectionSet *acdoc*)
      (setq start (vlax-curve-getPointAtParam
		    obj
		    (vlax-curve-getStartParam obj)
		  )
	    norm  (vunit
		    (vlax-curve-getFirstDeriv
		      obj
		      (vlax-curve-getStartParam obj)
		    )
		  )
      )
      (setq reg (vla-copy prof))
      (setq mat
	     (mxm
	       (mapcar
		 (function
		   (lambda (x)
		     (trans x 0 norm T)
		   )
		 )
		 (list '(1 0 0) '(0 1 0) '(0 0 1))
	       )
	       (mapcar
		 (function
		   (lambda (x)
		     (trans x (vlax-get reg 'Normal) 0 T)
		   )
		 )
		 (list '(1 0 0) '(0 1 0) '(0 0 1))
	       )
	     )
      )
      (vla-TransformBy
	reg
	(vlax-tmatrix
	  (append
	    (mapcar
	      (function
		(lambda	(v o)
		  (append v (list o))
		)
	      )
	      mat
	      (mapcar '- start (mxv mat org))
	    )
	    (list '(0 0 0 1))
	  )
	)
      )
      (vla-addExtrudedSolidAlongPath Space reg obj)
      (vla-delete reg)
    )
    (vla-EndUndoMark *acdoc*)
  )
      )
   )
   (princ "\nEntité non valide.")
 )
 (princ)
)

;; VXV Retourne le produit scalaire (réel) de deux vecteurs
(defun vxv (v1 v2)
 (apply '+ (mapcar '* v1 v2))
)

;; VLEN Retourne la longueur (norme) d'un vecteur
(defun vlen (v)
 (sqrt (vxv v v))
)

;; VUNIT Retourne le vecteur unitaire d'un vecteur
(defun vunit (v / l)
 (if (/= 0 (setq l (vlen v)))
   (mapcar '(lambda (x) (/ x l)) v)
 )
)

;; transpose une matrice Doug Wilson
(defun trp (m)
 (apply 'mapcar (cons 'list m))
)

;; Appli une matrice de transformation à un vecteur (Vladimir Nesterovsky)
(defun mxv (m v)
 (mapcar '(lambda (r) (vxv r v)) m)
)

;; Multiplie deux matrices (Vladimir Nesterovsky)
(defun mxm (m q)
 (mapcar '(lambda (r) (mxv (trp q) r)) m)
) 

[Edité le 13/1/2008 par (gile)]

 

[Edité le 15/1/2008 par (gile)]

[cdi]

 

Salut gile

 

Pour info, j'ai voulu testé Extrusion sur chemins multiples sur deux machines différentes et sauf erreur

voilà le message ligne de cde

 

erreur: cdrs supplémentaire dans la paire pointée en entrée.

 

 

@+

[(gile)]

Salut,

 

Au temps pour moi, c'est encore un problème de "

 

Le code est corrigé, ça devrait fonctionner maintenant.

 

Merci pour le retour ;)

 

[Edité le 15/1/2008 par (gile)]

[cdi]

 

PAS DE PB C'EST OK

 

 

je regarde ton ouvrage un peu plus tard

 

 

merc à toi Gile