Ellipses->polylignes 2

[(gile)]

Salut,

 

J'avais ça, mais ça me convenait à moitié (trop d'appels de la fonction command).

 

J'ai trouvé, ici, la méthode utilisée par AutoCAD pour les approximations d'ellipses en polylignes (succession d'arcs) quand PELLIPSE = 1.

 

Voilà donc une nouvelle version (plus rapide) des commandes:

EL2PL : pour convertir une sélection d'ellipses ou arcs elliptiques en polylignes

PELL : pour dessiner "à la volée" des approximations d'ellipses ou d'arcs elliptiques(polylignes)

 

Ces commandes appellent la routine EllipseToPolyline qui implémente la méthode sus-citée.

Les objets source sont supprimés ou conservés en fonction de la valeur de la variable DELOBJ.

La routine fonctionne quel que soit le plan de construction de l'ellipse.

La polyligne est créée sur le calque courant avec les propriétés courantes.

Pour une compatibilité avec les version

 

;; EllipseToPolyline (gile)
;; Retourne une polyline (vla-object) qui est une approximation de l'ellipse (ou de l'arc elliptique)
;; L'ellipse source est conservée ou supprimée en fonction de la valeur de DELOBJ
;;
;; Argument : une ellipse (vla-object)

(defun EllipseToPolyline (el    /  doc   cl    norm  cen   elv   pt0   pt1   pt2
                         pt3   pt4   ac0   ac4   a04   a02   a24   bsc1  bsc2
                         bsc3  bsc4  plst  blst  spt   spa   fspa  srat  ept
                         epa   fepa  erat  n
                        )
 (vl-load-com)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
       spc (if (= 1 (getvar 'cvport))
             (vla-get-PaperSpace doc)
             (vla-get-ModelSpace doc)
           )
       cl   (and (= (vla-get-StartAngle el) 0.0)
                 (= (vla-get-EndAngle el) (* 2 pi))
            )
       norm (vlax-get el 'Normal)
       cen  (trans (vlax-get el 'Center) 0 norm)
       elv  (caddr cen)
       cen  (3dTo2dPt cen)
       pt0  (mapcar '+ (trans (vlax-get el 'MajorAxis) 0 norm) cen)
       ac0  (angle cen pt0)
       pt4  (mapcar '+ cen (trans (vlax-get el 'MinorAxis) 0 norm))
       pt2  (3dTo2dPt (trans (vlax-curve-getPointAtparam el (/ pi 4.)) 0 norm))
       ac4  (angle cen pt4)
       a04  (angle pt0 pt4)
       a02  (angle pt0 pt2)
       a24  (angle pt2 pt4)
       bsc1 (/ (ang<2pi (- a02 ac4)) 2.)
       bsc2 (/ (ang<2pi (- a04 a02)) 2.)
       bsc3 (/ (ang<2pi (- a24 a04)) 2.)
       bsc4 (/ (ang<2pi (- (+ ac0 pi) a24)) 2.)
       pt1  (inters pt0
                    (polar pt0 (+ ac0 (/ pi 2.) bsc1) 1.)
                    pt2
                    (polar pt2 (+ a02 bsc2) 1.)
                    nil
            )
       pt3  (inters pt2
                    (polar pt2 (+ a04 bsc3) 1.)
                    pt4
                    (polar pt4 (+ a24 bsc4) 1.)
                    nil
            )
       plst (list pt4 pt3 pt2 pt1 pt0)
       blst (mapcar '(lambda (B) (tan (/ b 2.)))
                    (list bsc4 bsc3 bsc2 bsc1)
            )
 )
 (repeat 2
   (foreach b blst
     (setq blst (cons b blst))
   )
 )
 (foreach p (cdr plst)
   (setq ang  (angle cen p)
         plst (cons
                (polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p))
                plst
              )
   )
 )
 (foreach p (cdr plst)
   (setq ang  (angle cen p)
         plst (cons
                (polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p))
                plst
              )
   )
 )
 (setq pl
        (vlax-invoke
          spc
          'AddLightWeightPolyline
          (apply 'append
                 (setq plst
                        (reverse (if cl
                                   (cdr plst)
                                   plst
                                 )
                        )
                 )
          )
        )
 )
 (vlax-put pl 'Normal norm)
 (vla-put-Elevation pl elv)
 (mapcar '(lambda (i v) (vla-SetBulge pl i v))
         '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
         blst
 )
 (if cl
   (vla-put-Closed pl :vlax-true)
   (progn
     (setq spt  (vlax-curve-getClosestPointTo pl (vlax-get el 'Startpoint))
           spa  (vlax-curve-getParamAtPoint pl spt)
           fspa (fix spa)
           ept  (vlax-curve-getClosestPointTo pl (vlax-get el 'Endpoint))
           epa  (vlax-curve-getParamAtPoint pl ept)
           fepa (fix epa)
           n    0
     )
     (cond
       ((equal spt (trans pt0 norm 0) 1e-9)
        (if (= epa fepa)
          (setq plst (sublist plst 0 (1+ fepa))
                blst (sublist blst 0 (1+ fepa))
          )
          (setq erat (/ (- (vlax-curve-getDistAtParam pl epa)
                      (vlax-curve-getDistAtParam pl fepa)
                   )
                   (- (vlax-curve-getDistAtParam pl (1+ fepa))
                      (vlax-curve-getDistAtParam pl fepa)
                   )
                )
                plst (append (sublist plst 0 (1+ fepa))
                             (list (3dTo2dPt (trans ept 0 norm)))
                     )
                blst (append (sublist blst 0 (1+ fepa))
                             (list (k*bulge (nth fepa blst) erat))
                     )
          )
        )
       )
       ((equal ept (trans pt0 norm 0) 1e-9)
        (if (= spa fspa)
          (setq plst (sublist plst fspa nil)
                blst (sublist blst fspa nil)
          )
          (setq srat (/ (- (vlax-curve-getDistAtParam pl (1+ fspa))
                           (vlax-curve-getDistAtParam pl spa)
                        )
                        (- (vlax-curve-getDistAtParam pl (1+ fspa))
                           (vlax-curve-getDistAtParam pl fspa)
                        )
                     )
                plst (cons (3dTo2dPt (trans spt 0 norm))
                           (sublist plst (1+ fspa) nil)
                     )
                blst (cons (k*bulge (nth fspa blst) srat)
                           (sublist blst (1+ fspa) nil)
                     )
          )
        )
       )
       (T
        (setq srat (/ (- (vlax-curve-getDistAtParam pl (1+ fspa))
                           (vlax-curve-getDistAtParam pl spa)
                        )
                        (- (vlax-curve-getDistAtParam pl (1+ fspa))
                           (vlax-curve-getDistAtParam pl fspa)
                        )
                     )
              erat (/ (- (vlax-curve-getDistAtParam pl epa)
                      (vlax-curve-getDistAtParam pl fepa)
                   )
                   (- (vlax-curve-getDistAtParam pl (1+ fepa))
                      (vlax-curve-getDistAtParam pl fepa)
                   )
                )
              )
        (if (< epa spa)
          (setq plst (append
                       (if (= spa fspa)
                         (sublist plst fspa nil)
                         (cons (3dTo2dPt (trans spt 0 norm))
                               (sublist plst (1+ fspa) nil)
                         )
                       )
                       (cdr (sublist plst 0 (1+ fepa)))
                       (if (/= epa fepa)
                         (list (3dTo2dPt (trans ept 0 norm)))
                       )
                     )
                blst (append
                       (if (= spa fspa)
                         (sublist blst fspa nil)
                         (cons 
                           (k*bulge (nth fspa blst) srat)
                               (sublist blst (1+ fspa) nil)
                         )
                       )
                       (sublist blst 0 fepa)
                       (if (= epa fepa)
                         (list (nth fepa blst))
                         (list (k*bulge (nth fepa blst) erat))
                       )
                     )
          )
          (setq plst (append
                       (if (= spa fspa)
                         (sublist plst fspa (1+ (- fepa fspa)))
                         (cons (3dTo2dPt (trans spt 0 norm))
                               (sublist plst (1+ fspa) (- fepa fspa))
                         )
                       )
                       (list (3dTo2dPt (trans ept 0 norm)))
                     )
                blst (append
                       (if (= spa fspa)
                         (sublist blst fspa (- fepa fspa))
                         (cons
                           (k*bulge (nth fspa blst) srat)
                               (sublist blst (1+ fspa) (- fepa fspa))
                         )
                       )
                       (if (= epa fepa)
                         (list (nth fepa blst))
                         (list (k*bulge (nth fepa blst) erat))
                       )
                     )
          )
        )
       )
     )
     (vla-delete pl)
     (setq pl (vlax-invoke spc 'AddLightWeightPolyline (apply 'append plst)))
     (vlax-put pl 'Normal norm)
     (vla-put-Elevation pl elv)
     (foreach b blst
       (vla-SetBulge pl n B)
       (setq n (1+ n))
     )
   )
 )
 (or (zerop (getvar 'delobj)) (vla-delete el))
 pl
)

;; Ang<2pi
;; Retourne l'angle, à 2*k*pi près, compris entre 0 et 2*pi
(defun ang<2pi (ang)
 (if (and (<= 0 ang) (< ang (* 2 pi)))
   ang
   (ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
 )
)

;; 3dTo2dPt
;; Retourne le point 2d (x y) d'un point 3d (x y z)
(defun 3dTo2dPt (pt) (list (car pt) (cadr pt)))

;; Tan
;; Retourne la tangent de l'angle
(defun tan (a) (/ (sin a) (cos a)))

;;; SUBLIST Retourne une sous-liste
;;;
;;; Arguments
;;; lst : une liste
;;; start : l'index de départ de la sous liste (premier élément = 0)
;;; leng : la longueur (nombre d'éléments) de la sous-liste (ou nil)
(defun sublist (lst start leng / n r)
 (if (or (not leng) (< (- (length lst) start) leng))
   (setq leng (- (length lst) start))
 )
 (setq n (+ start leng))
 (while (< start n)
   (setq r (cons (nth (setq n (1- n)) lst) r))
 )
)

;; K*BULGE
;; Retourne le bulge proportionnel au bulge de référence
;; Arguments :
;; b : le bulge
;; k : le rapport de proportion (entre les angles ou les longueurs d'arcs)
(defun k*bulge (b k / a)
 (setq a (atan B))
 (/ (sin (* k a)) (cos (* k a)))
)

 

Les commandes :

 

;; EL2PL (gile)
;; Convertit ellipses et arcs elliptiques en polylignes
;; Les objets source sont conservés si la variable DELOBJ = 0,
;; supprimés sinon.

(defun c:el2pl (/ *error* fra acdoc ss)
 (vl-load-com)
 (defun *error* (msg)
   (if (and (/= msg "Fonction annulée")
            (/= msg "Function cancelled")
       )
     (princ (strcat (if (= "FRA" (getvar 'locale))
                      "\nErreur: "
                      "\Error: "
                    )
                    msg
            )
     )
   )
   (vla-endUndoMark acdoc)
   (princ)
 )
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (ssget '((0 . "ELLIPSE")))
   (progn
     (vla-StartUndoMark acdoc)
     (vlax-for e (setq ss (vla-get-ActiveSelectionSet acdoc))
       (EllipseToPolyline e)
     )
     (vla-delete ss)
     (vla-EndUndoMark acdoc)
   )
 )
 (princ)
)

;; PELL (gile)
;; Dessine "à la volée" une approximation d'ellipse ou arc elliptique (polyligne)

(defun c:pell (/ *error* ec pe do old ent)
 (vl-load-com)
 (defun *error* (msg)
   (if (and msg
            (/= msg "Fonction annulée")
            (/= msg "Function cancelled")
       )
     (princ (strcat (if (= "FRA" (getvar 'locale))
                      "\nErreur: "
                      "\Error: "
                    )
                    msg
            )
     )
   )
   (setvar 'cmdecho ec)
   (setvar 'pellipse pe)
   (setvar 'delobj do)
   (princ)
 )
 (setq ec  (getvar 'cmdecho)
       pe  (getvar 'pellipse)
       do  (getvar 'delobj)
       old (entlast)
 )
 (setvar 'cmdecho 1)
 (setvar 'pellipse 0)
 (command "_.ellipse")
 (while (/= 0 (getvar "cmdactive"))
   (command pause)
 )
 (if (not (eq old (setq ent (entlast))))
   (progn
     (setvar 'delobj 1)
   (EllipseToPolyline (vlax-ename->vla-object ent))
   )
 )
 (*error* nil)
)

[Raph_38]

Je n'ai pas personnellement besoin de ce lisp mais je tenais toutefois à te remercier pour ces lisps qui nous (me) servent tant.

 

Un sacré boulot ;)

[Thygraig]

Un grand merci à toi Gile.

 

j'ai lutté pour trouver une astuce qui marche correctement, et celle ci m'a vraiment fait gagner un temps fou.

 

mes 470 ellipses et moi te remercions.

[(gile)]

Salut et bienvenue,

 

Content que ça t'ait aidé.

[Tramber]

Ces routines m'on servi un peu aussi ici depuis le plan théorique.

[Dinosor]

Merci à tous, je vais tester...

[rimbo]

Bonjour gile, j'ai installé le lisp EL2PL et autocad map 2013 sous seven 64 bits me retourne ce commentaire :

Erreur: no function definition: ELLIPSETOPOLYLINE

 

est ce dut à la version 2013 ?

[lecrabe]

Hello

 

La version que j'ai de la routine EL2PL de Gilles fonctionne parfaitement (ou presque) sur AutoCAD 2013 32 bits

- OK sur les vraies Ellipses

- Pour les Arcs elliptiques, elle construit en Polyligne l'Arc INVERSE !

(Petit bug, pas tres grave car je n'ai pas d'Arc elliptique, du moins jusqu'a maintenant !)

 

Je joins a mon msg "ma" version de EL2PL ... A tester sur ton AutoCAD 64 bits !?

 

lecrabe

 

[(gile)]

Rimbo,

Le nom de la commande est : EL2PL

 

lecrabe,

Tu as une (très) vieille version.

La version ci-dessus est plus performante et n'a pas ce bug (à ma connaissance).

[bryce]

Bonjour,

 

Erreur: no function definition: ELLIPSETOPOLYLINE

 

J'ai l'impression que Rimbo n'a pas chargé la routine ELLIPSETOPOLYLINE dont EL2PL a besoin... :unsure:

[lecrabe]

Hello Gilles

 

EXACT comme toujours, en fait j'avais plusieurs versions ...

mais j'ai utilise cette "mauvaise" version car je n'ai jamais transforme des arcs elliptiques !?

 

Merci pour le rappel / mise a niveau sur cette excellente routine ...

 

Bonne Soiree, lecrabe

[rimbo]

Bonjour,

 

 

 

J'ai l'impression que Rimbo n'a pas chargé la routine ELLIPSETOPOLYLINE dont EL2PL a besoin... :unsure:

 

Exact je n'avait chargé que la moitié du programme merci ça fonctionne parfaitement et merci à gile pour ce programme... ;)

[Syl2007]

Post original du 10 novembre 2009. Et ça me sert maintenant, le 19 décembre 2013, plus de 4 ans après. C'est fou. Ou c'est moi qui suis simplement impressionnable.

 

Bon, encore un merci à Gile.

 

Sylvain