Comment déduire des longueurs de segment d'une polyligne ?

[oran]

Bonjour,

 

Je souhaite tracer une polyligne d'une longueur bien précise mais de façon qu'Autocad me déduise automatiquement les longueurs des segments que je trace afin que je sache au fur et à mesure ce qu'il me reste comme longueur.

 

Exemple: une polyligne de 10,00ml à tracer

- je trace mon 1er segment de 2,00ml ---> Autocad me dit qu'il reste 8,00ml

- je trace mon 2ème segment de 1.50ml ---> Autocad me dit qu'il reste encore 6,50ml etc ......

 

Est-ce faisable par lisp ??? :blink:

 

Merci d'avance.

[(gile)]

Salut,

 

Je pensais l'avoir déjà publiée ici mais je ne la retrouve pas.

 

La routine ci-dessous affiche dynamiquement la longueur restante (restrictions : plus d’accrochages aux objets et uniquement des segments droits).

 

;; PLL
;; Dessine un polyligne de longueur limitée
(defun c:PLL (/          *error*    drawSegment           drawPline  makePline  color
             segLen     cursor     loop       points     input      result     maxPt
             dist
            )

 ;; redéfinition locale de la fonction *error*
 (defun *error* (msg)
   (and msg
        (/= msg "Fonction annulée")
        (prompt (strcat "\nErreur: " msg))
   )
   (grtext)
   (redraw)
   (princ)
 )

 ;; affichage temporaire des segments déjà spécifiés
 (defun drawPline (points)
   (mapcar
     '(lambda (p1 p2) (grdraw p1 p2 color))
     points
     (cdr points)
   )
 )

 ;; mise à jour du point extreme et affichage temporaire du dernier segment
 (defun drawSegment (basePt dragPt segLen)
   (setq maxPt (polar basePt (angle basePt dragPt) segLen))
   (if (< (distance basePt dragPt) segLen)
     (progn
       (grdraw basePt dragPt -1)
       (grdraw dragPt maxPt 8 1)
     )
     (grdraw basePt maxPt -1)
   )
 )

 ;; création de la polyligne
 (defun makePline (points / ucszdir)
   (setq ucszdir (trans '(0 0 1) 1 0 T))
   (entmakex
     (append
       (list
         (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (length points))
         (cons 70 0)
         (cons 38 (caddr (trans '(0 0 0) 1 ucszdir)))
         (cons 210 ucszdir)
       )
       (mapcar
         '(lambda (p) (cons 10 (trans p 1 ucszdir)))
         points
       )
     )
   )
 )

 ;; fonction principale
 (sssetfirst nil nil)
 (or (numberp *PlineMaxLength*) (setq *PlineMaxLength* 5000.0)) ;_ valeur par défaut initiale
 (setq color (cdr (assoc 62 (tblsearch "layer" (getvar 'clayer)))))
 (if
   (and
     (or
       (and
         (setq
           segLen (getdist
                    (strcat "\nSpécifiez la longueur maximale <" (rtos *PlineMaxLength*) ">: ")
                  )
         )
         (setq *PlineMaxLength* segLen)
       )
       (setq segLen *PlineMaxLength*)
     )
     (setq basePt (getpoint "\nSpécifiez le premier point: "))
     (setq points (cons basePt points)
           input  ""
           loop   T
     )
   )
    (progn
      (prompt (strcat "\nCliquez le point suivant (longueur restante : " (rtos seglen) "): "))
      (while
        (and (setq result (grread T 12 0)) loop)
         (cond
           ;; mise à jour en fonction de la position du curseur
           ((= (car result) 5)
            (setq cursor (cadr result))
            (redraw)
            (drawPline points)
            (drawSegment (car points) cursor segLen)
           )
           ;; clic gauche
           ((= 3 (car result))
            (setq dist (distance (car points) cursor))
            (if (< dist segLen)
              (progn
                (setq points (cons cursor points)
                      segLen (- segLen dist)
                )
                (prompt (strcat "\nCliquez le point suivant ou validez (longueur restante : " (rtos seglen) "): "))
              )
              (progn
                (makePline (cons maxPt points))
                (setq loop nil)
              )
            )
           )
           ;; validation
           ((or (equal result '(2 13)) ;_ Entrée
                (equal result '(2 32)) ;_ Espace
                (= (car result) 25) ;_ clic droit
            )
            (makePline points)
            (setq loop nil)
           )
         )
      )
    )
 )
 (*error* nil)
)

[oran]

Bonjour,

 

Un grand merci à toi Gile, ta routine correspond exactement à ce que je cherche, je ne pouvais espérer mieux.