Jump to content

Sum Lines by Linetype

Jozef13

By Jozef13
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Jozef13 Enthusiast

Jozef13

Posted
Posted

Dear all,

I am looking for a lisp for Sum of Length for selected PolyLines and Lines by their Linetype.

E.g.:

LineType.....Length

Cu10-6.......25.0

Cu12-6.......20.0

Cu16-6.......0.0

Cu16-10......35.0

Cu18-10......12.0

Cu22-10......10.0

Or in csv format, to be able to copy/export it to excel

Link to comment
Share on other sites
BIGAL Grand Master

BIGAL

Posted
Posted

This is code by lee-mac and I have added a bit to it its nearly there but I need some time to fix.

 

Grrr bylayer has no assoc 6

 

;;  Displays the total length of selected objects at the      ;;
;;  command line.                                             ;;
;;--------------------=={ Total Length }==--------------------;;
;;                                                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
(princ "\nType Tlen to run")
(defun c:tLen ( / lts lt)
 ;; © Lee Mac 2010
(setq lts (list "Cu10-6" "Cu12-6" "Cu16-6" "Cu16-10" "Cu18-10" "Cu22-10" ))
(repeat   (setq x (length lts))
 (setq lt (nth (setq x (- x 1)) lts))
 (
   (lambda ( SelSet Total i / entity )
     (if SelSet
       (princ
         (strcat "\nTotal Length: "
           (rtos
             (while (setq entity (ssname SelSet (setq i (1+ i))))
               (setq Total
                 (+
                   (vlax-curve-getDistAtParam entity
                     (vlax-curve-getEndParam entity)
                   )
                   Total
                 )
               )
             )
           )
         )
       )
     )
   )
   (ssget
     (list (cons 0 "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")(cons 6 lt)
       (cons -4 "<NOT")
         (cons -4 "<AND")
           (cons 0 "POLYLINE")
           (cons -4 "<OR")
             (cons -4 "&=") (cons 70 16)
             (cons -4 "&=") (cons 70 64)
           (cons -4 "OR>")
         (cons -4 "AND>")
       (cons -4 "NOT>")
     )
   )
   0.0 -1
 )
)
 (princ)
)

Link to comment
Share on other sites
Jozef13 Enthusiast

Jozef13

Posted
  • Author
Posted (edited)
This is code by lee-mac and I have added a bit to it its nearly there but I need some time to fix.

 

Grrr bylayer has no assoc 6

 

;;  Displays the total length of selected objects at the      ;;
;;  command line.                                             ;;
;;--------------------=={ Total Length }==--------------------;;
;;                                                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
(princ "\nType Tlen to run")
(defun c:tLen ( / lts lt)
 ;; © Lee Mac 2010
(setq lts (list "Cu10-6" "Cu12-6" "Cu16-6" "Cu16-10" "Cu18-10" "Cu22-10" ))
(repeat   (setq x (length lts))
 (setq lt (nth (setq x (- x 1)) lts))
 (
   (lambda ( SelSet Total i / entity )
     (if SelSet
       (princ
         (strcat "\nTotal Length: "
           (rtos
             (while (setq entity (ssname SelSet (setq i (1+ i))))
               (setq Total
                 (+
                   (vlax-curve-getDistAtParam entity
                     (vlax-curve-getEndParam entity)
                   )
                   Total
                 )
               )
             )
           )
         )
       )
     )
   )
   (ssget
     (list (cons 0 "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")(cons 6 lt)
       (cons -4 "<NOT")
         (cons -4 "<AND")
           (cons 0 "POLYLINE")
           (cons -4 "<OR")
             (cons -4 "&=") (cons 70 16)
             (cons -4 "&=") (cons 70 64)
           (cons -4 "OR>")
         (cons -4 "AND>")
       (cons -4 "NOT>")
     )
   )
   0.0 -1
 )
)
 (princ)
)

I have also modified Lee-Mac code and my working result is here:

(vl-load-com)

(defun c:tlenLT	(/ e i l s ltlist lt ltname)
;;;  (setq LTfilter "TZB*,BYLAYER")
 (setq LTfilter "*")
 (if (setq s
     (ssget
       '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")
	 (-4 . "<NOT")
	 (-4 . "<AND")
	 (0 . "POLYLINE")
	 (-4 . "&")
	 (70 . 80)
	 (-4 . "AND>")
	 (-4 . "NOT>")
	)
     )
     )

   (progn
;;;      vvv Generate Linetypes List from selection
     (repeat (setq i (sslength s))
(setq e	     (ssname s (setq i (1- i)))
      ltname (cdr (assoc 6 (entget e)))
)
(if (= ltname nil) (setq ltname "BYLAYER"))
(if (and (not (member ltname ltlist))
	 (wcmatch ltname LTfilter)
    )
  (progn
    (setq ltlist (cons ltname ltlist))		;adds linetype name to list
  )
)
     )  ;;;repeat
;;;      ^^^^ Generate Linetypes List from selection
     (foreach lt ltlist
(setq l 0.0)
(repeat	(setq i (sslength s))
  (setq	e      (ssname s (setq i (1- i)))
	ltname (cdr (assoc 6 (entget e)))
  )
  (if (= ltname nil) (setq ltname "BYLAYER"))
  (if (= ltname lt)
    (setq l (+ l
	       (vlax-curve-getdistatparam
		 e
		 (vlax-curve-getendparam e)
	       )
	    )
    )
  )
)

;;;            (princ "\nTotal Length: ")
(princ (strcat lt "," (rtos (/ l 1000.0))))
(princ "\n")
     )
   )
 )
 (textscr)
 (princ)
)
(princ)

Edited by Jozef13
Added code tags
Link to comment
Share on other sites
Grrr Veteran

Grrr

Posted
Posted

implementing my tought into code..

(defun C:test ( / SS aL i e itm ltp b ) 
 (if
   (setq SS
     (ssget "_:L-I" 
       '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")
         (-4 . "<NOT")
         (-4 . "<AND")
         (0 . "POLYLINE")
         (-4 . "&")
         (70 . 80)
         (-4 . "AND>")
         (-4 . "NOT>")
       )
     )
   )
   (progn
     (setq aL '())
     (repeat (setq i (sslength SS))
       (setq e (ssname SS (setq i (1- i))))
       (setq itm
         (cons
           (setq ltp (cond ( (cdr (assoc 6 (entget e))) ) ( "ByLayer" ) ))
           (+ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) (setq b (cond ( (cdr (assoc ltp aL)) ) (0.))))
         )
       )
       (if (zerop b)
         (setq aL (cons itm aL))
         (setq aL (subst itm (assoc (car itm) aL) aL))
       )
     )
     (princ "\n============\n")
     (foreach x (vl-sort aL ''((a b) (apply '< (mapcar 'car (list a b)))) )
       (princ (car x)) (princ " : ") (princ (rtos (cdr x) 2 4))
       (princ "\n")
     )
     (princ "============")
     (textscr)
   )
 )
 (princ)
)

Link to comment
Share on other sites
Jozef13 Enthusiast

Jozef13

Posted
  • Author
Posted
implementing my tought into code..

(defun C:test ( / SS aL i e itm ltp b ) 
 (if
   (setq SS
     (ssget "_:L-I" 
       '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")
         (-4 . "<NOT")
         (-4 . "<AND")
         (0 . "POLYLINE")
         (-4 . "&")
         (70 . 80)
         (-4 . "AND>")
         (-4 . "NOT>")
       )
     )
   )
   (progn
     (setq aL '())
     (repeat (setq i (sslength SS))
       (setq e (ssname SS (setq i (1- i))))
       (setq itm
         (cons
           (setq ltp (cond ( (cdr (assoc 6 (entget e))) ) ( "ByLayer" ) ))
           (+ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) (setq b (cond ( (cdr (assoc ltp aL)) ) (0.))))
         )
       )
       (if (zerop b)
         (setq aL (cons itm aL))
         (setq aL (subst itm (assoc (car itm) aL) aL))
       )
     )
     (princ "\n============\n")
     (foreach x (vl-sort aL ''((a b) (apply '< (mapcar 'car (list a b)))) )
       (princ (car x)) (princ " : ") (princ (rtos (cdr x) 2 4))
       (princ "\n")
     )
     (princ "============")
     (textscr)
   )
 )
 (princ)
)

 

Hmm... nice short code :) and well working.

Link to comment
Share on other sites
ronjonp Grand Master

ronjonp

Posted
Posted
implementing my tought into code..

(defun C:test ( / SS aL i e itm ltp b ) 
 (if
   (setq SS
     (ssget "_:L-I" 
       '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")
         (-4 . "<NOT")
         (-4 . "<AND")
         (0 . "POLYLINE")
         (-4 . "&")
         (70 . 80)
         (-4 . "AND>")
         (-4 . "NOT>")
       )
     )
   )
   (progn
     (setq aL '())
     (repeat (setq i (sslength SS))
       (setq e (ssname SS (setq i (1- i))))
       (setq itm
         (cons
           (setq ltp (cond ( (cdr (assoc 6 (entget e))) ) ( "ByLayer" ) ))
           (+ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) (setq b (cond ( (cdr (assoc ltp aL)) ) (0.))))
         )
       )
       (if (zerop b)
         (setq aL (cons itm aL))
         (setq aL (subst itm (assoc (car itm) aL) aL))
       )
     )
     (princ "\n============\n")
     (foreach x (vl-sort aL ''((a b) (apply '< (mapcar 'car (list a b)))) )
       (princ (car x)) (princ " : ") (princ (rtos (cdr x) 2 4))
       (princ "\n")
     )
     (princ "============")
     (textscr)
   )
 )
 (princ)
)

 

Nice Grrr .. maybe a little addition :)

           (princ "============")
          (if (> (length al) 1)
            (princ
              (strcat "\nTOTAL : "
                      (vl-princ-to-string (apply '+ (mapcar 'cdr al)))
              )
            )
          )
          (textscr)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...