PDA

View Full Version : Linetype length calculator



RyanAtNelco
19th Jun 2009, 07:42 pm
Hello,

Is there anyone out there who can help me with a routine that selects all lines of a certain linetype, and displays the total length of all lines with that linetype? I was originally trying to do this with fields and a table but there are just too many lines in the particular file im working with, and i would like to be able to do this in general without setting up a field for every line.

Thanks a million!

Commandobill
19th Jun 2009, 07:54 pm
Is each one of the linetypes 'bylayer' or are they all set seperately or a mix of both. *side note - I used to work in woburn...*

RyanAtNelco
19th Jun 2009, 07:58 pm
As of right now they are set separately, but i was considering making new layers and setting it to "by layer". The issue with this is i would have to mess with my companies pen settings as all the standard colors are set, and my company is strict about modifying such things. Then everyone else would need the new pen settings, and as the low man on the totem pole i'd rather avoid company wide changes =).

RyanAtNelco
19th Jun 2009, 07:59 pm
where in woburn? im near the mall on gill st

Commandobill
19th Jun 2009, 08:14 pm
About 2 miles down the road. I worked at skyworks inc. Of course that was about 5 years ago. Ill see what i can make for you...

RyanAtNelco
19th Jun 2009, 08:16 pm
your the man! i dont want to ask too much, but is there a way you can comment it out? i would like to learn how to make my own :)

Commandobill
19th Jun 2009, 08:21 pm
Sure. What do you plan on doing with the numbers once you get them? You want them in excel or a text file or somewhere in the dwg?

RyanAtNelco
19th Jun 2009, 08:22 pm
excel would be perfect, it is for some takeoffs for lead quantities

RyanAtNelco
19th Jun 2009, 08:23 pm
oh i also have a bunch of line types i would like to do this for representing lead of different thicknesses, do you need the names of the line types?

Lee Mac
19th Jun 2009, 08:25 pm
Just made this as a quickie :



(defun c:ltlen (/ ldef lt ss len)
(vl-load-com)
(setq ldef (cdr (assoc 2 (tblnext "LTYPE" T))))
(while
(progn
(setq lt
(getstring t
(strcat "\nSpecify Linetype <" ldef ">: ")))
(cond ((eq "" lt) (setq lt ldef) nil) ; Exit Loop
((not (snvalid lt))
(princ "\n** Linetype Name Not Valid **"))
((not (tblsearch "LTYPE" lt))
(princ "\n** Linetype Not Found in Drawing **"))
(t nil))))
(if (setq ss (ssget "_X" (list (cons 0 "LINE") (cons 6 lt))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss))))))
(princ (strcat "\n<< Total Length of " (rtos (sslength ss) 2 0)
" Lines is: " (rtos len 2 2))))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(princ))

RyanAtNelco
19th Jun 2009, 08:30 pm
LeeMac - thanks a bunch, however i only get a message saying: << No Lines Found With Linetype Continuous >>

there are def. continuous lines in the drawing, and i tried this with my custom linetype as well with no luck :(

Lee Mac
19th Jun 2009, 08:31 pm
LeeMac - thanks a bunch, however i only get a message saying: << No Lines Found With Linetype Continuous >>

there are def. continuous lines in the drawing, and i tried this with my custom linetype as well with no luck :(

Sorry, forgot to mention this will not work on lines set to BYLAYER - need more coding for that :)

But just made it quickly to beat Bill to it :P

RyanAtNelco
19th Jun 2009, 08:34 pm
for this project, my lines are overridden to specific linetypes. this usually not the case, but my company is out of colors and i have to mess with some new colors and pen settings and get permission from the higher ups to change all that.

Commandobill
19th Jun 2009, 08:47 pm
Sorry i didnt comment out what it does. Ill have to do that this weekend or on monday im at work and the day is almost over.


(defun c:lte (/ drac ltype ltlst xlSheets leng pline row ss sumlen total x xlApp xlBook xlBooks xlCells xlSheet)
(vl-load-com)
(setq xlApp (vlax-get-or-create-object "Excel.Application")
xlBooks (vlax-get-property xlApp "Workbooks")
xlBook (vlax-invoke-method xlBooks "Add")
xlSheets (vlax-get-property xlBook "Sheets")
xlSheet (vlax-get-property xlSheets "Item" 1)
xlCells (vlax-get-property xlSheet "Cells")
)
(vla-put-visible xlApp :vlax-true)
(vlax-put-property xlCells "Item" 1 1 "Linetype")
(vlax-put-property xlCells "Item" 1 2 "Length")
(setq ltlst (list (cdr (assoc 2 (tblnext "Ltype" t)))))
(while (setq ltynm (tblnext "Ltype"))
(setq ltlst (append (list (cdr (assoc 2 ltynm)))ltlst))
)
(setq row 2
total 0)
(repeat (length ltlst)
(setq ltype (car ltlst))
(if (setq ss (ssget "_X" (list (cons 0 "*LINE")(cons 6 ltype))))
(progn
(setq drac -1 sumlen 0)
(repeat (sslength ss)
(setq pline (vlax-ename->vla-object (ssname ss (setq drac (1+ drac)))))
(setq leng (vlax-curve-getdistatparam pline
(vlax-curve-getendparam pline)))
(setq sumlen (+ sumlen leng)))
(vlax-put-property xlCells "Item" row 1 ltype)
(vlax-put-property xlCells "Item" row 2 (rtos sumlen 2 3))
(setq total (+ total sumlen))
(setq ltlst (cdr ltlst))
(setq row (+ row 1))
)))
(setq row (+ row 1))
(vlax-put-property xlCells "Item" row 1 "Total:")
(vlax-put-property xlCells "Item" row 2 (rtos total 2 3))

(mapcar (function (lambda(x)
(vl-catch-all-apply
(function (lambda()
(progn
(vlax-release-object x)
(setq x nil)))))))
(list xlCells xlSheet xlSheets xlBook xlBooks xlApp)
)
(alert "Close Excel file manually")
(gc)(gc)
(princ)
)

Commandobill
19th Jun 2009, 08:50 pm
Sorry, forgot to mention this will not work on lines set to BYLAYER - need more coding for that :)

But just made it quickly to beat Bill to it :P

I too didnt make mine so that it would get linetypes that are 'bylayer'

Ahahaha you sure did beat me to it... and once i saw yours i changed alot of my coding so that it wasnt as similar... (i took out my mapcars) :o

Lee Mac
19th Jun 2009, 08:50 pm
Bill, yours will only deal with lines not set to BYLAYER yeah?

Also - it will pick up all *POLYLINEs, and LINEs - I wasn't sure if the OP wanted just LINEs..

Anyway, this should deal with those *LINEs set to BYLAYER:

{Some funky ss filter...}



(defun c:ltlen (/ ldef lt tdef ss len laylst)
(vl-load-com)
(setq laylst "")

(setq ldef (cdr (assoc 2 (tblnext "LTYPE" T))))
(while
(progn
(setq lt
(getstring t
(strcat "\nSpecify Linetype <" ldef ">: ")))
(cond ((eq "" lt) (setq lt (strcase ldef)) nil)
((not (snvalid lt))
(princ "\n** Linetype Name Not Valid **"))
((not (tblsearch "LTYPE" lt))
(princ "\n** Linetype Not Found in Drawing **"))
(t (setq lt (strcase lt)) nil))))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laylst
(strcat (cdr (assoc 2 tdef)) (chr 44) laylst))))
(setq laylst (vl-string-right-trim (chr 44) laylst))

(if (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt) (cons -4 "<AND")
(cons -4 "<NOT") (cons 6 "*") (cons -4 "NOT>")
(cons 8 laylst) (cons -4 "AND>") (cons -4 "OR>"))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss))))))
(princ (strcat "\n<< Total Length of " (rtos (sslength ss) 2 0)
" Lines is: " (rtos len 2 2))))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(princ))

Commandobill
19th Jun 2009, 08:56 pm
Bill, yours will only deal with lines not set to BYLAYER yeah?

Also - it will pick up all *POLYLINEs, and LINEs - I wasn't sure if the OP wanted just LINEs..

Anyway, this should deal with those *LINEs set to BYLAYER:

{Some funky ss filter...}



Aww not fair.. I dont know how to use (cons -4) yet... you code too fast for me lol. Ill top yours sometime this weekend if i get the chance :twisted: :lol:

Commandobill
19th Jun 2009, 08:59 pm
Oh speaking of which is there a good post on (cons -4) ?

RyanAtNelco
19th Jun 2009, 09:01 pm
these are great! they both do what i want pretty well

i know i said earlier that i wanted it in excel, but is there a way to put it in a table in autocad too? after more thought on the subject this will be easier in the end. Lee if yours was to put the values of several line types into a table it would be absolutly perfect i would imagine a lot of people would be able to use this to save a lot of time.

thanks again for your hard work guys these are really great!!! :)

Lee Mac
19th Jun 2009, 09:02 pm
the -4 code in the ss filter is not really that hard to grasp tbh, even you should be able to get it Bill :P

To explain it briefly, it works just like a conditional within the filter:

Hence:



(list (cons 0 "CIRCLE")
(cons -4 "<OR") (cons 40 5) (cons 8 "0") (cons -4 "OR>"))


Means, all Circles either on layer "0" or with radius 5 (or both as OR is inclusive, use XOR for non-inclusivity).

Just enclose the terms in "<OR" "OR>" -4 lists, as shown.

Lee Mac
19th Jun 2009, 09:03 pm
Oh speaking of which is there a good post on (cons -4) ?

AfraLISP has a great section on it:

http://www.afralisp.net/lisp/filter.htm (http://www.afralisp.net/lisp/filter.htm)

Lee Mac
19th Jun 2009, 09:04 pm
Lee if yours was to put the values of several line types into a table it would be absolutly perfect i would imagine a lot of people would be able to use this to save a lot of time.

Now that's something I'm new to... having worked on '04 pretty much the whole time, I have never coded for a table in CAD... but I'll see what it entails..

Lee Mac
19th Jun 2009, 09:13 pm
LeeMac - thanks a bunch, however i only get a message saying: << No Lines Found With Linetype Continuous >>

there are def. continuous lines in the drawing, and i tried this with my custom linetype as well with no luck :(

One more thing - just to clarify, are we definitely dealing with ALL *LINES - i.e. POLYLINES, LWPOLYLINES and LINES?

RyanAtNelco
19th Jun 2009, 09:16 pm
Yes that would be ideal.

Also i know this is probably difficult to code, but in the perfect world:

run script

select/type-in several line types

table generated showing each linetype's length in units, length in (units/12), and length in (units/48)

RyanAtNelco
19th Jun 2009, 09:16 pm
that last bit was supposed to be (units/ 48 )

CAB
19th Jun 2009, 09:45 pm
Late entry. :)

;;================================================ =============
;; LtLength.lsp by Charles Alan Butler
;; Copyright 2008
;; by Precision Drafting & Design All Rights Reserved.
;; Contact CAB at TheSwamp.org
;;
;; Version 1.0 Beta April 4,2008
;;
;; Total Length by linetype
;; Totals length with ByLayer & layer has matching linetype
;;================================================ =============
(defun c:LTLength (/ ent col Ltype Ltypes layers ss lt:lst lt:prompt ss:first
elst filter lay:lst x ent:lst total cnt get_layer get_layerByLT)
(vl-load-com)
;; return a list of layers using the linetype in the list
;; lt:lst is a list of LineType names
(defun get_layerByLT (lt:lst / lay lays doc)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for lay (vla-get-layers doc)
(if (and (member (vla-get-linetype lay) lt:lst)
(not (vl-string-search "|" (vla-get-name lay)))
)
(setq lays (cons (vla-get-name lay) lays))
)
)
lays
)


;; ================================================== ===============
;; Main Routine
;; ================================================== ===============
(setq ent_allowed '("LINE" "LWPOLYLINE" "POLYLINE" "SPLINE" "ARC" "CIRCLE" "DIMENSION"))
;; get anything already selected
(setq ss:first (cadr(ssgetfirst))
ss (ssadd))

;; Get user selected linetypes
(if ss:first
(setq lt:prompt "\nSelect the object to choose linetype to use.")
(setq lt:prompt "\nSelect object for linetype filter.")
)
;;------------------------------------------------------------------
(while (setq ent (entsel lt:prompt))
(redraw (car ent) 3) ; highlite the object
(setq ent:lst (cons (car ent) ent:lst))
(setq Ltype(cdr(assoc 6 (entget (car ent))))); get the lineType
(if (null Ltype) ; LT is ByLayer, get layer LT
(setq Ltype(cdr (assoc 6
(tblsearch "layer"
(cdr (assoc 8 (entget (car ent))))))))
)
(setq lt:lst (cons Ltype lt:lst))
;;(prompt (strcat "\n*-* Selected Color # -> " (get_color_name col)))
)
;;------------------------------------------------------------------
;; Un HighLite the entities
(and ent:lst (mapcar '(lambda (x) (redraw x 4)) ent:lst))
(if (> (length lt:lst) 0); got LT to work with
(progn
(setq lt:lst (vl-sort lt:lst '<)) ; removes douplicates
(setq Ltypes "" layers "")
(setq lay:lst (get_layerByLT lt:lst)) ; get layers using the LineType
(foreach itm lt:lst ; combine linetype names into one , del string
(setq Ltypes (strcat Ltypes itm ",")))
(setq Ltypes (substr Ltypes 1 (1- (strlen Ltypes)))); remove the last ,
(foreach itm lay:lst ; combine layer names into one , del string
(setq layers (strcat layers itm ",")))
(setq layers (substr layers 1 (1- (strlen layers)))); remove the last ,
;;================================================ ==============
(if ss:first ; ALREADY GOT SELECTION SET
(while (setq ent (ssname ss:first 0))
(setq elst (entget ent))
(if (or (and (assoc 6 elst) ; got a LT
(member (abs (cdr(assoc 6 elst))) lt:lst)) ; LT match
(and layers
(member (cdr(assoc 8 elst)) lay:lst)
(or (null (assoc 6 elst))
(= (cdr(assoc 62 elst)) 256))) ; bylayer
)
(ssadd (ssname ss:first 0) ss)
)
(ssdel (ssname ss:first 0) ss:first)
)
;; else get a selection set to work with
(progn
(prompt (strcat "\nOK >>--> Select objects for Selection set or "
"ENTER for All objects with LineType(s) " Ltypes))
;; create the filter
(if layers
(setq filter (append
(cons '(-4 . "<OR") (mapcar '(lambda (x) (cons 6 x)) lt:lst))
(list '(-4 . "<AND")
(cons 8 layers)
'(62 . 256) ; ByLayer
'(-4 . "AND>")
'(-4 . "OR>")
)))
(setq filter (list (cons 6 Ltypes)))
)
;; get objects using filter with user select
(if (null (setq ss (ssget filter)))
;; or get ALL objects using filter
(setq ss (ssget "_X" filter))
)
)
)
;;================================================ ==============
(if (> (sslength ss) 0)
(progn
;; convert selection set to list of vla objects
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq total 0
cnt 0)

(foreach en lst
(setq len nil)
(if (member (setq typ (cdr (assoc 0 (entget en)))) ent_allowed)
(progn
(setq obj (vlax-ename->vla-object en))
(cond
((vlax-property-available-p obj 'Measurement)
(setq len (vla-get-measurement obj))
)
((vlax-property-available-p obj 'Length)
(setq len (vla-get-length obj))
)
((setq len (vl-catch-all-apply
'(lambda()(vlax-curve-getdistatparam en (vlax-curve-getendparam en)))))
(and (vl-catch-all-error-p len)(setq len nil))
)
)
(if len
(setq total (+ len total)
cnt (1+ cnt))
)
) ; progn
)
)


(if (zerop total)
(princ "\nNo length found.")
(princ (strcat "\nTotal Length of " (itoa cnt) " objects is " (rtos total)))
)
;;(sssetfirst nil ss)
)
(prompt "\n*** Nothing Selected ***")
)
)
)
(princ)
)
(prompt "\nLinetype Length loaded, Enter LtLength to run.")
(princ)

Lee Mac
19th Jun 2009, 10:21 pm
Hopefully with Table!



;; Linetype Length by Lee McDonnell 19.06.2009
;; (contact Lee Mac @ CADTutor.net, TheSwamp.org)

(defun c:ltlen (/ laystr doc spc l ltlst tdef
laystr laylst ss Objlst len
lenlst i tblObj)

(vl-load-com)
(setq laystr "" i 2)

(setq doc (vla-get-ActiveDocument
(vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true) ; Vport
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(while (setq l (tblnext "LTYPE" (not l)))
(setq ltlst (cons (cdr (assoc 2 l)) ltlst)))

(if (verChk)
(if (setq bPt (getpoint "\nSelect Point for Table: "))
(progn

(foreach lt (mapcar 'strcase (reverse ltlst))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
laylst (cons (cdr (assoc 2 tdef)) laylst))))
(setq laystr (vl-string-right-trim (chr 44) laystr))

(if (and (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt)
(cons 8 laystr) (cons -4 "OR>"))))
(setq Objlst
(vl-remove-if
(function
(lambda (x)
(and
(vl-position
(cdr (assoc 8 (entget x))) laylst)
(assoc 6 (entget x)))))
(mapcar 'cadr (ssnamex ss)))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object Objlst))))
(setq lenlst (cons (list lt (/ len 12.) (/ len 48.)) lenlst)))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(setq tdef nil laystr "" laylst nil))
(if lenlst
(progn
(setq tblObj
(vla-addTable spc
(vlax-3D-point bPt)
(+ 2 (length lenlst)) 3 (* 1.5 (getvar "TEXTSIZE"))
(* (apply 'max
(mapcar 'strlen
(mapcar 'car lenlst))) 1.5 (getvar "TEXTSIZE"))))
(vla-setText tblObj 0 0 "{\\fCopperplate Gothic Light|b1|i0|c0|p34;\\C3;Linetype Lengths}")
(vla-setText tblObj 1 0 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;Name}")
(vla-setText tblObj 1 1 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/12}")
(vla-setText tblObj 1 2 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/48}")
(foreach x (reverse lenlst)
(vla-setCellAlignment tblObj i 0 acMiddleCenter)
(vla-setText tblObj i 0 (car x))
(vla-setCellAlignment tblObj i 1 acMiddleCenter)
(vla-setText tblObj i 1 (rtos (cadr x) 2 2))
(vla-setCellAlignment tblObj i 2 acMiddleCenter)
(vla-setText tblObj i 2 (rtos (caddr x) 2 2))
(setq i (1+ i))))))
(princ "\n<< No Base Point Specified >>"))
(princ "\n<< No Table Object in this Version >>"))
(princ))

(defun verchk ()
(if (>= (distof (substr (getvar "ACADVER") 1 4)) 17)
T nil))

Commandobill
20th Jun 2009, 08:10 pm
the -4 code in the ss filter is not really that hard to grasp tbh, even you should be able to get it Bill :P



Lol your pretty funny for being from England. :P

*Disclamer - Any views or opinions presented in this post are solely those of the Commandobill and do not necessarily represent those of the United States. Seriously though it was just a joke. :lol:

Commandobill
20th Jun 2009, 08:14 pm
AfraLISP has a great section on it:

http://www.afralisp.net/lisp/filter.htm (http://www.afralisp.net/lisp/filter.htm)


Thank you Ill have to look into it. Currently i have a medical condition called a hangover that is keeping my ambition to do any coding at a minimal. :wink:

Lee Mac
20th Jun 2009, 09:06 pm
Lol your pretty funny for being from England. :P

*Disclamer - Any views or opinions presented in this post are solely those of the Commandobill and do not necessarily represent those of the United States. Seriously though it was just a joke. :lol:


Hahaha o:)

RyanAtNelco
22nd Jun 2009, 02:54 pm
Lee,

I am using your code to try to figure out how this table thing works. If i wanted to add a column to the table for the category "x/1" (or just "x"), what section of code would i want to be looking at?

Thanks!

ps

The script does work awesome!!!! Is there a way to choose which layers get put into the table?

Lee Mac
22nd Jun 2009, 03:01 pm
Lee,

I am using your code to try to figure out how this table thing works. If i wanted to add a column to the table for the category "x/1" (or just "x"), what section of code would i want to be looking at?

Thanks!

ps

The script does work awesome!!!! Is there a way to choose which layers get put into the table?


Glad you like it Ryan,

I shall add an extra column to the code for you - as it may not be too simple.

As for the selection of layers - do you mean linetypes? And would you want to type in which you want to have in the table?

RyanAtNelco
22nd Jun 2009, 03:03 pm
lee,

I did mean linetypes haha (i just got to work im still half asleep :) ). Typing in the linetypes would be perfect.

Thanks!

Lee Mac
22nd Jun 2009, 03:06 pm
The following is with the extra Column, I shall work on Linetype Selection :)



;; Linetype Length by Lee McDonnell 19.06.2009
;; (contact Lee Mac @ CADTutor.net, TheSwamp.org)

(defun c:ltlen (/ laystr doc spc l ltlst tdef
laystr laylst ss Objlst len
lenlst i tblObj)

(vl-load-com)
(setq laystr "" i 2)

(setq doc (vla-get-ActiveDocument
(vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true) ; Vport
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(while (setq l (tblnext "LTYPE" (not l)))
(setq ltlst (cons (cdr (assoc 2 l)) ltlst)))

(if (verChk)
(if (setq bPt (getpoint "\nSelect Point for Table: "))
(progn

(foreach lt (mapcar 'strcase (reverse ltlst))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
laylst (cons (cdr (assoc 2 tdef)) laylst))))
(setq laystr (vl-string-right-trim (chr 44) laystr))

(if (and (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt)
(cons 8 laystr) (cons -4 "OR>"))))
(setq Objlst
(vl-remove-if
(function
(lambda (x)
(and
(vl-position
(cdr (assoc 8 (entget x))) laylst)
(assoc 6 (entget x)))))
(mapcar 'cadr (ssnamex ss)))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object Objlst))))
(setq lenlst (cons (list lt len (/ len 12.) (/ len 48.)) lenlst)))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(setq tdef nil laystr "" laylst nil))
(if lenlst
(progn
(setq tblObj
(vla-addTable spc
(vlax-3D-point bPt)
(+ 2 (length lenlst)) 4 (* 1.5 (getvar "TEXTSIZE"))
(* (apply 'max
(mapcar 'strlen
(mapcar 'car lenlst))) 1.5 (getvar "TEXTSIZE"))))
(vla-setText tblObj 0 0 "{\\fCopperplate Gothic Light|b1|i0|c0|p34;\\C3;Linetype Lengths}")
(vla-setText tblObj 1 0 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;Name}")
(vla-setText tblObj 1 1 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x}")
(vla-setText tblObj 1 2 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/12}")
(vla-setText tblObj 1 3 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/48}")
(foreach x (reverse lenlst)
(vla-setCellAlignment tblObj i 0 acMiddleCenter)
(vla-setText tblObj i 0 (car x))
(vla-setCellAlignment tblObj i 1 acMiddleCenter)
(vla-setText tblObj i 1 (rtos (cadr x) 2 2))
(vla-setCellAlignment tblObj i 2 acMiddleCenter)
(vla-setText tblObj i 2 (rtos (caddr x) 2 2))
(vla-setCellAlignment tblObj i 3 acMiddleCenter)
(vla-setText tblObj i 3 (rtos (cadddr x) 2 2))
(setq i (1+ i))))))
(princ "\n<< No Base Point Specified >>"))
(princ "\n<< No Table Object in this Version >>"))
(princ))

(defun verchk ()
(if (>= (distof (substr (getvar "ACADVER") 1 4)) 17)
T nil))

RyanAtNelco
22nd Jun 2009, 03:07 pm
Good lord you are fast man.

Lee Mac
22nd Jun 2009, 03:10 pm
Good lord you are fast man.

o:) I try.. :P

Commandobill
22nd Jun 2009, 03:24 pm
o:) I try.. :P

I hope you try this hard at school :P

Lee Mac
22nd Jun 2009, 03:47 pm
Ok Ryan, I have spent a bit of time dabbling with the way you can add the linetypes. Its slightly different from the usual - let me know if you get any bugs :)



;; Linetype Length by Lee McDonnell 22.06.2009
;; (contact Lee Mac @ CADTutor.net, TheSwamp.org)

(defun c:ltlen (/ *error* laystr doc spc l ltlst tdef
laystr laylst ss Objlst len
lenlst i tblObj vChk lt ent)

(vl-load-com)
(setq laystr "" i 2)

(setq doc (vla-get-ActiveDocument
(vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true) ; Vport
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n<< Error: " msg " >>")))
(princ))

(if (not (>= (distof (substr (getvar "ACADVER") 1 4)) 17))
(progn
(princ "\n<< Table Object Not Available in this Version >>") (exit)))
(if (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
(progn
(princ "\n<< Current Layer Locked >>") (exit)))

(while
(progn
(initget 128 "Select List All Done")
(setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: "))
(cond ((not lt) nil) ; Enter
((eq "Done" lt) nil)
((eq "Select" lt)
(if (setq ent (car (nentsel "\nSelect Object: ")))
(progn
(setq lt (strcase
(vla-get-linetype
(setq Obj (vlax-ename->vla-object ent)))))
(cond ((eq lt "BYLAYER")
(if (vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ( )
(setq lt
(strcase
(vla-get-linetype
(vla-item
(vla-get-Layers doc) (vla-get-layer Obj)))))))))
(princ "\n<< Error Retrieving Linetype >>")
(if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))))
(t (if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>")))))))
t)) ; Stay in Loop
((eq "List" lt)
(if ltlst
(progn
(foreach lt ltlst
(princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop
(princ "\n<< No List Created >>")))
((eq "All" lt)
(setq ltlst nil)
(while (setq l (tblnext "LTYPE" (not l)))
(setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop
((and (snvalid lt)
(tblsearch "LTYPE" lt))
(setq ltlst (cons (strcase lt) ltlst)))
(t (princ "\n<< Linetype not Found in Drawing >>")))))

(if ltlst
(if (setq bPt (getpoint "\nSelect Point for Table: "))
(progn

(foreach lt (mapcar 'strcase (reverse ltlst))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
laylst (cons (cdr (assoc 2 tdef)) laylst))))
(setq laystr (vl-string-right-trim (chr 44) laystr))

(if (and (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt)
(cons 8 laystr) (cons -4 "OR>"))))
(setq Objlst
(vl-remove-if
(function
(lambda (x)
(and
(vl-position
(cdr (assoc 8 (entget x))) laylst)
(assoc 6 (entget x)))))
(mapcar 'cadr (ssnamex ss)))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object Objlst))))
(setq lenlst (cons (list lt len (/ len 12.) (/ len 48.)) lenlst)))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(setq tdef nil laystr "" laylst nil))
(if lenlst
(progn
(setq tblObj
(vla-addTable spc
(vlax-3D-point bPt)
(+ 2 (length lenlst)) 4 (* 1.5 (getvar "TEXTSIZE"))
(* (apply 'max
(mapcar 'strlen
(mapcar 'car lenlst))) 1.5 (getvar "TEXTSIZE"))))
(vla-setText tblObj 0 0 "{\\fCopperplate Gothic Light|b1|i0|c0|p34;\\C3;Linetype Lengths}")
(vla-setText tblObj 1 0 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;Name}")
(vla-setText tblObj 1 1 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x}")
(vla-setText tblObj 1 2 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/12}")
(vla-setText tblObj 1 3 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/48}")
(foreach x (reverse lenlst)
(vla-setCellAlignment tblObj i 0 acMiddleCenter)
(vla-setText tblObj i 0 (car x))
(vla-setCellAlignment tblObj i 1 acMiddleCenter)
(vla-setText tblObj i 1 (rtos (cadr x) 2 2))
(vla-setCellAlignment tblObj i 2 acMiddleCenter)
(vla-setText tblObj i 2 (rtos (caddr x) 2 2))
(vla-setCellAlignment tblObj i 3 acMiddleCenter)
(vla-setText tblObj i 3 (rtos (cadddr x) 2 2))
(setq i (1+ i))))))
(princ "\n<< No Base Point Specified >>"))
(princ "\n<< No Linetypes Specified >>"))
(princ))

(defun pad (str chc len)
(while (< (strlen Str) len)
(setq str (strcat str (chr chc))))
str)

RyanAtNelco
22nd Jun 2009, 04:05 pm
Lee,

This is awesome, it works perfectly! You got me thinkin however, so now I'm really going to pick your brain... (just for bonus points, as the routine does everything necessary) is there a way to check off the linetypes you want similar to the way you select properties in the "stripmtext" routine by steve doman? Also i think it would be useful if there was a way to check the length of objects by other properties like layer, color, etc.

Let me know what you think in terms of how difficult that would be.

Lee Mac
22nd Jun 2009, 04:10 pm
Lee,

This is awesome, it works perfectly! You got me thinkin however, so now I'm really going to pick your brain... (just for bonus points, as the routine does everything necessary) is there a way to check off the linetypes you want similar to the way you select properties in the "stripmtext" routine by steve doman? Also i think it would be useful if there was a way to check the length of objects by other properties like layer, color, etc.

Let me know what you think in terms of how difficult that would be.

"stripmtext" uses a DCL to get the dialog - not too difficult, but more time consuming. But, seeing as all my exams have finished, and I've got nothing on til I get my results this Thursday, I'll see what I can come up with. :)

RyanAtNelco
22nd Jun 2009, 04:11 pm
Awesome!:D:shock:

stevesfr
22nd Jun 2009, 10:56 pm
Ok Ryan, I have spent a bit of time dabbling with the way you can add the linetypes. Its slightly different from the usual - let me know if you get any bugs :)



;; Linetype Length by Lee McDonnell 22.06.2009
;; (contact Lee Mac @ CADTutor.net, TheSwamp.org)

(defun c:ltlen (/ *error* laystr doc spc l ltlst tdef
laystr laylst ss Objlst len
lenlst i tblObj vChk lt ent)

(vl-load-com)
(setq laystr "" i 2)

(setq doc (vla-get-ActiveDocument
(vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true) ; Vport
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n<< Error: " msg " >>")))
(princ))

(if (not (>= (distof (substr (getvar "ACADVER") 1 4)) 17))
(progn
(princ "\n<< Table Object Not Available in this Version >>") (exit)))
(if (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
(progn
(princ "\n<< Current Layer Locked >>") (exit)))

(while
(progn
(initget 128 "Select List All Done")
(setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: "))
(cond ((not lt) nil) ; Enter
((eq "Done" lt) nil)
((eq "Select" lt)
(if (setq ent (car (nentsel "\nSelect Object: ")))
(progn
(setq lt (strcase
(vla-get-linetype
(setq Obj (vlax-ename->vla-object ent)))))
(cond ((eq lt "BYLAYER")
(if (vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ( )
(setq lt
(strcase
(vla-get-linetype
(vla-item
(vla-get-Layers doc) (vla-get-layer Obj)))))))))
(princ "\n<< Error Retrieving Linetype >>")
(if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))))
(t (if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>")))))))
t)) ; Stay in Loop
((eq "List" lt)
(if ltlst
(progn
(foreach lt ltlst
(princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop
(princ "\n<< No List Created >>")))
((eq "All" lt)
(setq ltlst nil)
(while (setq l (tblnext "LTYPE" (not l)))
(setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop
((and (snvalid lt)
(tblsearch "LTYPE" lt))
(setq ltlst (cons (strcase lt) ltlst)))
(t (princ "\n<< Linetype not Found in Drawing >>")))))

(if ltlst
(if (setq bPt (getpoint "\nSelect Point for Table: "))
(progn

(foreach lt (mapcar 'strcase (reverse ltlst))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
laylst (cons (cdr (assoc 2 tdef)) laylst))))
(setq laystr (vl-string-right-trim (chr 44) laystr))

(if (and (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt)
(cons 8 laystr) (cons -4 "OR>"))))
(setq Objlst
(vl-remove-if
(function
(lambda (x)
(and
(vl-position
(cdr (assoc 8 (entget x))) laylst)
(assoc 6 (entget x)))))
(mapcar 'cadr (ssnamex ss)))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object Objlst))))
(setq lenlst (cons (list lt len (/ len 12.) (/ len 48.)) lenlst)))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(setq tdef nil laystr "" laylst nil))
(if lenlst
(progn
(setq tblObj
(vla-addTable spc
(vlax-3D-point bPt)
(+ 2 (length lenlst)) 4 (* 1.5 (getvar "TEXTSIZE"))
(* (apply 'max
(mapcar 'strlen
(mapcar 'car lenlst))) 1.5 (getvar "TEXTSIZE"))))
(vla-setText tblObj 0 0 "{\\fCopperplate Gothic Light|b1|i0|c0|p34;\\C3;Linetype Lengths}")
(vla-setText tblObj 1 0 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;Name}")
(vla-setText tblObj 1 1 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x}")
(vla-setText tblObj 1 2 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/12}")
(vla-setText tblObj 1 3 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x/48}")
(foreach x (reverse lenlst)
(vla-setCellAlignment tblObj i 0 acMiddleCenter)
(vla-setText tblObj i 0 (car x))
(vla-setCellAlignment tblObj i 1 acMiddleCenter)
(vla-setText tblObj i 1 (rtos (cadr x) 2 2))
(vla-setCellAlignment tblObj i 2 acMiddleCenter)
(vla-setText tblObj i 2 (rtos (caddr x) 2 2))
(vla-setCellAlignment tblObj i 3 acMiddleCenter)
(vla-setText tblObj i 3 (rtos (cadddr x) 2 2))
(setq i (1+ i))))))
(princ "\n<< No Base Point Specified >>"))
(princ "\n<< No Linetypes Specified >>"))
(princ))

(defun pad (str chc len)
(while (< (strlen Str) len)
(setq str (strcat str (chr chc))))
str)


Lee, Great job once again... give me a clue on how to omit the last two columns as all I need is the x/1 or x column.
Steve

Lee Mac
22nd Jun 2009, 11:06 pm
Lee, Great job once again... give me a clue on how to omit the last two columns as all I need is the x/1 or x column.
Steve

Cheers Steve :D

Its probably best that I alter the code for you, as its not a simple change :P



;; Linetype Length by Lee McDonnell 22.06.2009
;; (contact Lee Mac @ CADTutor.net, TheSwamp.org)

(defun c:ltlen (/ *error* laystr doc spc l ltlst tdef
laystr laylst ss Objlst len
lenlst i tblObj vChk lt ent)

(vl-load-com)
(setq laystr "" i 2)

(setq doc (vla-get-ActiveDocument
(vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true) ; Vport
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n<< Error: " msg " >>")))
(princ))

(if (not (>= (distof (substr (getvar "ACADVER") 1 4)) 17))
(progn
(princ "\n<< Table Object Not Available in this Version >>") (exit)))
(if (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
(progn
(princ "\n<< Current Layer Locked >>") (exit)))

(while
(progn
(initget 128 "Select List All Done")
(setq lt (getkword "\nSpecify Linetype to List [Select/List/All] <Done>: "))
(cond ((not lt) nil) ; Enter
((eq "Done" lt) nil)
((eq "Select" lt)
(if (setq ent (car (nentsel "\nSelect Object: ")))
(progn
(setq lt (strcase
(vla-get-linetype
(setq Obj (vlax-ename->vla-object ent)))))
(cond ((eq lt "BYLAYER")
(if (vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ( )
(setq lt
(strcase
(vla-get-linetype
(vla-item
(vla-get-Layers doc) (vla-get-layer Obj)))))))))
(princ "\n<< Error Retrieving Linetype >>")
(if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))))
(t (if ltlst
(if (vl-position lt ltlst)
(princ (strcat "\n<< " lt " Linetype Already Listed >>"))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>"))))
(progn
(setq ltlst (cons lt ltlst))
(princ (strcat "\n<< " lt " Linetype Added to List >>")))))))
t)) ; Stay in Loop
((eq "List" lt)
(if ltlst
(progn
(foreach lt ltlst
(princ (strcat "\n" (Pad lt 46 30)))) (textscr) t) ; Stay in Loop
(princ "\n<< No List Created >>")))
((eq "All" lt)
(setq ltlst nil)
(while (setq l (tblnext "LTYPE" (not l)))
(setq ltlst (cons (cdr (assoc 2 l)) ltlst))) nil) ; Exit Loop
((and (snvalid lt)
(tblsearch "LTYPE" lt))
(setq ltlst (cons (strcase lt) ltlst)))
(t (princ "\n<< Linetype not Found in Drawing >>")))))

(if ltlst
(if (setq bPt (getpoint "\nSelect Point for Table: "))
(progn

(foreach lt (mapcar 'strcase (reverse ltlst))

(while (setq tdef (tblnext "LAYER" (not tdef)))
(if (eq lt (strcase (cdr (assoc 6 tdef))))
(setq laystr (strcat (cdr (assoc 2 tdef)) (chr 44) laystr)
laylst (cons (cdr (assoc 2 tdef)) laylst))))
(setq laystr (vl-string-right-trim (chr 44) laystr))

(if (and (setq ss (ssget "_X" (list (cons 0 "*LINE")
(cons -4 "<OR") (cons 6 lt)
(cons 8 laystr) (cons -4 "OR>"))))
(setq Objlst
(vl-remove-if
(function
(lambda (x)
(and
(vl-position
(cdr (assoc 8 (entget x))) laylst)
(assoc 6 (entget x)))))
(mapcar 'cadr (ssnamex ss)))))
(progn
(setq len
(apply '+
(mapcar
(function
(lambda (x)
(vla-get-Length x)))
(mapcar 'vlax-ename->vla-object Objlst))))
(setq lenlst (cons (list lt len) lenlst)))
(princ (strcat "\n<< No Lines Found With Linetype " lt " >>")))
(setq tdef nil laystr "" laylst nil))
(if lenlst
(progn
(setq tblObj
(vla-addTable spc
(vlax-3D-point bPt)
(+ 2 (length lenlst)) 2 (* 1.5 (getvar "TEXTSIZE"))
(* (apply 'max
(mapcar 'strlen
(mapcar 'car lenlst))) 1.5 (getvar "TEXTSIZE"))))
(vla-setText tblObj 0 0 "{\\fCopperplate Gothic Light|b1|i0|c0|p34;\\C3;Linetype Lengths}")
(vla-setText tblObj 1 0 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;Name}")
(vla-setText tblObj 1 1 "{\\fCopperplate Gothic Light|b1|i1|c0|p34;\\C16;x}")
(foreach x (reverse lenlst)
(vla-setCellAlignment tblObj i 0 acMiddleCenter)
(vla-setText tblObj i 0 (car x))
(vla-setCellAlignment tblObj i 1 acMiddleCenter)
(vla-setText tblObj i 1 (rtos (cadr x) 2 2))
(setq i (1+ i))))))
(princ "\n<< No Base Point Specified >>"))
(princ "\n<< No Linetypes Specified >>"))
(princ))

(defun pad (str chc len)
(while (< (strlen Str) len)
(setq str (strcat str (chr chc))))
str)

stevesfr
23rd Jun 2009, 12:25 am
Lee, thank you.. a couple of virtual pints your way. I didn't mean for all this work for you just to wax two columns. But it will be put to use over and over to assemble utility conduit quantities. Best regards, Steve

Lee Mac
23rd Jun 2009, 12:35 am
Lee, thank you.. a couple of virtual pints your way. I didn't mean for all this work for you just to wax two columns. But it will be put to use over and over to assemble utility conduit quantities. Best regards, Steve

No worries mate, it wasn't too much work to change - just a little tricky to explain through forum posts thats all :)

I'm glad it'll be put to good use mate - upgraded version on its way also 8)

Lee

RyanAtNelco
23rd Jun 2009, 02:09 pm
Lee,

How is the upgraded version going? The anticipation is killing me!!!! :P

Lee Mac
23rd Jun 2009, 03:54 pm
Lee,

How is the upgraded version going? The anticipation is killing me!!!! :P

Already completed.

Check out the new thread. :)

http://www.cadtutor.net/forum/showthread.php?t=37508

stevesfr
23rd Jun 2009, 05:12 pm
Sorry i didnt comment out what it does. Ill have to do that this weekend or on monday im at work and the day is almost over.


(defun c:lte (/ drac ltype ltlst xlSheets leng pline row ss sumlen total x xlApp xlBook xlBooks xlCells xlSheet)
(vl-load-com)
(setq xlApp (vlax-get-or-create-object "Excel.Application")
xlBooks (vlax-get-property xlApp "Workbooks")
xlBook (vlax-invoke-method xlBooks "Add")
xlSheets (vlax-get-property xlBook "Sheets")
xlSheet (vlax-get-property xlSheets "Item" 1)
xlCells (vlax-get-property xlSheet "Cells")
)
(vla-put-visible xlApp :vlax-true)
(vlax-put-property xlCells "Item" 1 1 "Linetype")
(vlax-put-property xlCells "Item" 1 2 "Length")
(setq ltlst (list (cdr (assoc 2 (tblnext "Ltype" t)))))
(while (setq ltynm (tblnext "Ltype"))
(setq ltlst (append (list (cdr (assoc 2 ltynm)))ltlst))
)
(setq row 2
total 0)
(repeat (length ltlst)
(setq ltype (car ltlst))
(if (setq ss (ssget "_X" (list (cons 0 "*LINE")(cons 6 ltype))))
(progn
(setq drac -1 sumlen 0)
(repeat (sslength ss)
(setq pline (vlax-ename->vla-object (ssname ss (setq drac (1+ drac)))))
(setq leng (vlax-curve-getdistatparam pline
(vlax-curve-getendparam pline)))
(setq sumlen (+ sumlen leng)))
(vlax-put-property xlCells "Item" row 1 ltype)
(vlax-put-property xlCells "Item" row 2 (rtos sumlen 2 3))
(setq total (+ total sumlen))
(setq ltlst (cdr ltlst))
(setq row (+ row 1))
)))
(setq row (+ row 1))
(vlax-put-property xlCells "Item" row 1 "Total:")
(vlax-put-property xlCells "Item" row 2 (rtos total 2 3))

(mapcar (function (lambda(x)
(vl-catch-all-apply
(function (lambda()
(progn
(vlax-release-object x)
(setq x nil)))))))
(list xlCells xlSheet xlSheets xlBook xlBooks xlApp)
)
(alert "Close Excel file manually")
(gc)(gc)
(princ)
)

This lte.lsp is dangerous. If someone grabs it and runs with it, it has bugs. See the attached dwg and Excel file.
What would be great, to salvage this program is:
1- have user save Excel file to a "user" name, or have Excel file exist before running LTE.
2-save the drawing name on first line of workbook
3-have the ability to append the Excel file with subsequent results of other drawings (so a family of plan sheets would have results all in one workbook)
Steve

Commandobill
23rd Jun 2009, 05:56 pm
Well... So many things to say. I'm exactly sure how to interpret your post, so I'll do my best.


This lte.lsp is dangerous.

How?


If someone grabs it and runs with it, it has bugs.

The only "bug" it may have is that it doesnt get the *lines that are "bylayer" which I could easily fix (using my new knowledge of (cons -4))
If there is something else about it that errors then let me know.


What would be great, to salvage this program is:
I'm not exactly sure what needs "salvaging" I wrote this program specifically for this thread.

As for the rest. I'm not sure if that is a personal request for you but it was not asked by the original poster thus me not having it setup that way. If he wanted it run on multiple drawings then I would have done something similar to what i did here (http://www.cadtutor.net/forum/showthread.php?t=36816&page=3) .

Like i said i may may misinterpreted what you said so please clarify if i took anything the wrong way.