Longueur multiligne

[pointpower]

Bonjour,

 

Svp j'ai un lisp qui calcule la longueur des objets (polylignes, lignes...) je voudrais aussi qu'il calcule la longueur des multilignes.

 

pourriez-vous svp le complèter.

 

Merci

 

; LongT.LSP c.2000

; 'Add selected lines, plines, splines, and arcs for total length'

;

 

 

(defun tlines ()

(setq lbeg (cdr (assoc '10 ent)))

(setq lend (cdr (assoc '11 ent)))

(setq llen (distance lbeg lend))

(setq tlen (+ tlen llen))

(ssdel sn ss1)

)

 

(defun tarcs ()

(setq cen (cdr (assoc '10 ent)))

(setq rad (cdr (assoc '40 ent)))

(setq dia (* rad 2.0))

(setq circ (* (* rad pi) 2.0))

(setq sang (cdr (assoc '50 ent)))

(setq eang (cdr (assoc '51 ent)))

(if (< eang sang)

(setq eang (+ eang (* pi 2.0)))

)

(setq tang (- eang sang))

(setq tang2 (* (/ tang pi) 180.0))

(setq circ2 (/ tang2 360.0))

(setq alen (* circ2 circ))

(setq tlen (+ tlen alen))

(princ)

(ssdel sn ss1)

)

 

(defun tplines ()

(command "_area" "e" sn)

(setq tlen (+ tlen (getvar "perimeter")))

(ssdel sn ss1)

)

 

(defun tsplines ()

(command "_area" "e" sn)

(setq tlen (+ tlen (getvar "perimeter")))

(ssdel sn ss1)

)

 

(DEFUN C:longT (/ tlen ss1 sn sn2 et)

(setq cmdecho (getvar "cmdecho"))

(setvar "cmdecho" 0)

(setq tlen 0)

(prompt "\nSelectionné les entités que vous voulez aditionner: ")

(setq ss1 (ssget))

(while (> (sslength ss1) 0)

(setq sn (ssname ss1 0))

(setq ent (entget sn))

(setq et (cdr (assoc '0 ent)))

(cond

((= et "LINE") (tlines))

((= et "ARC") (tarcs))

((= et "LWPOLYLINE") (tplines))

((= et "POLYLINE") (tplines))

((= et "SPLINE") (tsplines))

((or

(/= et "LINE")

(/= et "ARC")

(/= et "LWPOLYLINE")

(/= et "POLYLINE")

(/= et "SPLINE")

)

(ssdel sn ss1)

)

)

)

(alert (strcat "\nLa longueur des lignes, polylignes et arc selectionné est de: " (rtos tlen 2 2)))

(setvar "cmdecho" cmdecho)

(prompt "\nBy Colomb Claude R&R ")

(princ)

)

 

[Patrick_35]

Salut

Un exemple avec une sélection sur une multiligne.

Le résultat est dans la variable di

 

  (setq sel (entget (car (entsel)))
coord (vl-remove-if-not '(lambda(x) (eq (car x) 11)) sel)
pt (car coord)
di 0
 )
 (foreach pts (cdr coord)
   (setq di (+ di (distance (cdr pts) (cdr pt)))
  pt pts
   )
 )

 

@+

[pointpower]

Merci Patrick,

 

Mais je n'arrive pas à l'utiliser, stp pourrais tu complèter le fichier LongT avec ton code afin de tout avoir dedans (multilignes, polylignes,...)

 

dsl je suis novice en prog.

 

Encore merci

[Patrick_35]

Re,

Je l'ai refais en plus court

Il prend en compte les lignes, les polylignes 2D et 3D, les arcs de cercles, les cercles, les ellipses, les splines et les

 

multilignes.

 

(defun c:longT(/ di ent n pt1 pt2 sel)
 (vl-load-com)
 (if (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,MLINE")))
   (progn
     (setq di 0)
     (vlax-for ent (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(cond
  ((member (vla-get-objectname ent) '("AcDbLine" "AcDb3dPolyline" "AcDbPolyline"))
    (setq di (+ di (vla-get-length ent)))
  )
  ((eq (vla-get-objectname ent) "AcDbArc")
    (setq di (+ di (vla-get-arclength ent)))
  )
  ((eq (vla-get-objectname ent) "AcDbCircle")
    (setq di (+ di (vla-get-circumference ent)))
  )
  ((member (vla-get-objectname ent) '("AcDbSpline" "AcDbEllipse"))
    (setq di (+ di (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))))
  )
  ((eq (vla-get-objectname ent) "AcDbMline")
    (setq n 0 pt2 nil)
    (while (nth n (setq lst (vlax-get ent 'Coordinates)))
      (setq pt1 (list (nth n lst)(nth (1+ n) lst)(nth (+ n 2) lst)))
      (and pt2
	(setq di (+ di (distance pt1 pt2)))
      )
      (setq pt2 pt1
	    n (+ n 3)
      )
    )
  )
)
     )
     (if (eq (vla-get-count sel) 1)
       (alert (strcat "La longueur de l'objet est de : " (rtos di)))
       (alert (strcat "La longueur total des " (itoa (vla-get-count sel)) " objets est de : " (rtos di)))
     )
     (vla-delete sel)
   )
 )
 (princ)
)

 

@+

[lili2006]

Bonsoir à toutes et tous,

 

 

Pas mal l'option MLigne,..

 

Merci Patrick_35

[pointpower]

Merci beaucoup.

 

J'en avais besoin et j'espère que cela servira pour d'autres.

 

a+

[lecrabe]

 

Hello

 

En voici un autre qui cumule les longueurs/perimetres et aussi les surfaces/aires

Mais ne traite pas les Lignes & Arcs & Multi-Lignes

Cependant elle inclut les fameux MPOLYGONs de MAP ou CIVIL

 

J'ai commencé à utiliser cette routine en 1995-1996 avec l'abominable version R13 ! :o

 

Le Decapode

 

;;; 1st Routine for AUTOCAD R13, R14, R15 (OUPS ! 2000) - 04/2000
;;; 
;;; ZTOTM ou ZTOTCM.LSP - Version 1.0 by H LORIOT (C) 2000
;;; ZTOTM.LSP et Fonction ZTOTM (Because DWG en METRE)
;;;
;;; H LORIOT PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; H LORIOT SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. 
;;; H LORIOT DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM 
;;; WILL BE UNINTERRUPTED OR ERROR FREE.
;;;
;;; Modification par Patrice BRAUD - Version 1.1 en Lisp
;;; +SPLINE, +ELLIPSE
;;;
;;; Modification par Gilles - Version 2.0 en Visual-Lisp
;;; +MPOLYGON (de MAP ou CIVIL), +REGION
;;;
;;; Version 2.1 : Modif pour traiter AUSSI les Polylignes NON FERMEES/ NON CLOSES
;;; VITAL pour faire la somme de polylignes "ouvertes" : Reseaux par exemple
;;;
;;; Commande au clavier :  ZTOTM

(defun c:ztotm (/ ss cnt area len)
(vl-load-com)
(setq cnt 0 area 0.0 len 0.0)
(if (ssget 

(list
'(-4 . "'(0 . "CIRCLE")
'(-4 . "'(0 . "ELLIPSE")
'(41 . 0.0)
(cons 42 (* 2 pi))
'(-4 . "AND>")
'(-4 . "'(0 . "LWPOLYLINE")
;;; '(-4 . "&")
;;; '(70 . 1)
'(-4 . "AND>")
'(0 . "MPOLYGON")
'(-4 . "'(0 . "POLYLINE")
;;; '(-4 . "&")
;;; '(70 . 1)
'(-4 . "'(70 . 8)
'(-4 . "AND>")
'(0 . "REGION")
'(-4 . "'(0 . "SPLINE")
'(-4 . "&")
'(70 . 9)
'(-4 . "AND>")
'(-4 . "OR>")
)

)
(progn
(vlax-for obj (setq ss (vla-get-ActiveSelectionSet
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
(setq cnt (1+ cnt)
area (+ area (vla-get-area obj))
len (+ len
(if (member (vla-get-ObjectName obj)
'("AcDbMPolygon" "AcDbRegion")
)
(vla-get-Perimeter obj)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
)
)
)

(princ "\nZTOTM v2.1 - Cercle, Polyligne, Ellipse, Spline, Region, MPOLYGON")
(princ (strcat "\n""TOTAUX -Surface: "(rtos area)
" -Périmètre: "(rtos len)" -Objets: "(itoa cnt)
)
)
(vla-delete ss)
)
(prompt "\n*** Rien de Valable ")
)
(princ)
) 
(princ "\n==> ZTOTM (Version 2.1) ")
(princ) 

 

 

[Patrick_35]

Salut

 

J'ai modifié le lisp pour qu'il prenne en compte les Régions et les MPolygons.

 

(defun c:longT(/ di ent n pt1 pt2 sel)
 (vl-load-com)
 (if (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,MLINE,REGION,MPOLYGON")))
   (progn
     (setq di 0)
     (vlax-for ent (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(cond
  ((member (vla-get-objectname ent) '("AcDbLine" "AcDb3dPolyline" "AcDbPolyline"))
    (setq di (+ di (vla-get-length ent)))
  )
  ((eq (vla-get-objectname ent) "AcDbArc")
    (setq di (+ di (vla-get-arclength ent)))
  )
  ((eq (vla-get-objectname ent) "AcDbCircle")
    (setq di (+ di (vla-get-circumference ent)))
  )
  ((member (vla-get-objectname ent) '("AcDbSpline" "AcDbEllipse"))
    (setq di (+ di (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))))
  )
  ((eq (vla-get-objectname ent) "AcDbMline")
    (setq n 0 pt2 nil)
    (while (nth n (setq lst (vlax-get ent 'Coordinates)))
      (setq pt1 (list (nth n lst)(nth (1+ n) lst)(nth (+ n 2) lst)))
      (and pt2
	(setq di (+ di (distance pt1 pt2)))
      )
      (setq pt2 pt1
	    n (+ n 3)
      )
    )
  )
  ((member (vla-get-objectname ent) '("AcDbMPolygon" "AcDbRegion"))
    (setq di (+ di (vla-get-perimeter ent)))
  )
)
     )
     (if (eq (vla-get-count sel) 1)
       (alert (strcat "La longueur de l'objet est de : " (rtos di)))
       (alert (strcat "La longueur total des " (itoa (vla-get-count sel)) " objets est de : " (rtos di)))
     )
     (vla-delete sel)
   )
 )
 (princ)
)

 

@+

[lecrabe]

 

Hello Patrick

 

Ton programme est Nickel-Chrome et je l'ai testé sur MAP 2004 et sur MAP 2009

avec un dessin test perso contenant à peu près tous les types d'entités

sauf les Droites et Demi-Droites :)

 

Encore merci pour ton adaptation :D

 

En plus il peut être facilement modifié pour ne traiter que certaines entités

suivant les besoins persos de chacun :cool:

 

Le Decapode