stevesfr Posted June 22, 2009 Posted June 22, 2009 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 Quote
Lee Mac Posted June 22, 2009 Posted June 22, 2009 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 Its probably best that I alter the code for you, as its not a simple change ;; 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) Quote
stevesfr Posted June 22, 2009 Posted June 22, 2009 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 Quote
Lee Mac Posted June 22, 2009 Posted June 22, 2009 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 Lee Quote
RyanAtNelco Posted June 23, 2009 Author Posted June 23, 2009 Lee, How is the upgraded version going? The anticipation is killing me!!!! Quote
Lee Mac Posted June 23, 2009 Posted June 23, 2009 Lee, How is the upgraded version going? The anticipation is killing me!!!! Already completed. Check out the new thread. http://www.cadtutor.net/forum/showthread.php?t=37508 Quote
stevesfr Posted June 23, 2009 Posted June 23, 2009 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 TEST_LTE.dwg test_lte.txt Quote
Commandobill Posted June 23, 2009 Posted June 23, 2009 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 . Like i said i may may misinterpreted what you said so please clarify if i took anything the wrong way. Quote
Recommended Posts
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.