j_spawn_h Posted July 4, 2015 Share Posted July 4, 2015 Ok I have looked and I have not seem to fine a table that I am needing. I need a lisp to create a table. I swipe multiple lines and I need the table to take all there properties and create a table. Also has it is doing that I need it to combine like lines and add them up in a qty column. I seen a lot of tables but nothing I know how to change to do what I need. I am still reading and learning but still don't know enough to do this. Quote Link to comment Share on other sites More sharing options...
BIGAL Posted July 5, 2015 Share Posted July 5, 2015 This is not what you want but shows how to make a table and populate it with a variable amount of information. Instead of reading a block attribute you would just do a ssget of the text. ; DWG INDEX TO A TABLE ; BY ALAN H NOV 2013 (DEFUN AH:DWGINDEX (/ DOC OBJTABLE SS1 LAY ANS ANS2 PLOTABS SS1 TAG2 TAG3 LIST1 LIST2 CURLAYOUT COLWIDTH NUMCOLUMNS NUMROWS INC ROWHEIGHT ) (VL-LOAD-COM) (SETQ CURLAYOUT (GETVAR "CTAB")) (IF (= CURLAYOUT "MODEL") (PROGN (ALERT "YOU NEED TO BE IN A LAYOUT FOR THIS OPTION") (EXIT) ) ; END PROGN ) ; END IF MODEL (SETQ DOC (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) (SETQ CURSPACE (VLA-GET-PAPERSPACE DOC)) (SETQ PT1 (VLAX-3D-POINT (GETPOINT "\NPICK POINT FOR TOP LEFT HAND OF TABLE: "))) ; READ VALUES FROM TITLE BLOCKS (SETQ BNAME "DA1DRTXT") (SETQ TAG2 "DRG_NO") ;ATTRIBUTE TAG NAME (SETQ TAG3 "WORKS_DESCRIPTION") ;ATTRIBUTE TAG NAME (SETQ SS1 (SSGET "X" (LIST (CONS 0 "INSERT") (CONS 2 BNAME)))) (IF (= SS1 NIL) ; FOR TOMKINSON JOBS (PROGN (SETQ BNAME "xxx_TITLE") (SETQ SS1 (SSGET "X" (LIST (CONS 0 "INSERT") (CONS 2 BNAME)))) ) ) (SETQ INC (SSLENGTH SS1)) (REPEAT INC (FOREACH ATT (VLAX-INVOKE (VLAX-ENAME->VLA-OBJECT (SSNAME SS1 (SETQ INC (- INC 1)) )) 'GETATTRIBUTES) (IF (= TAG2 (STRCASE (VLA-GET-TAGSTRING ATT))) (PROGN (SETQ ANS (VLA-GET-TEXTSTRING ATT)) (IF (/= ANS NIL) (SETQ LIST1 (CONS ANS LIST1)) ) ; IF ); END PROGN ) ; END IF (IF (= TAG3 (STRCASE (VLA-GET-TAGSTRING ATT))) (PROGN (SETQ ANS2 (VLA-GET-TEXTSTRING ATT)) (IF (/= ANS2 NIL) (SETQ LIST2 (CONS ANS2 LIST2)) ) ; END IF ) ; END PROGN ) ; END IF TAG3 ) ; END FOREACH ) ; END REPEAT (SETVAR 'CTAB CURLAYOUT) (COMMAND-S "ZOOM" "E") (COMMAND-S "REGEN") (REVERSE LIST1) ;(REVERSE LIST2) ; NOW DO TABLE (SETQ NUMROWS (+ 2 (SSLENGTH SS1))) (SETQ NUMCOLUMNS 2) (SETQ ROWHEIGHT 0.2) (SETQ COLWIDTH 150) (SETQ OBJTABLE (VLA-ADDTABLE CURSPACE PT1 NUMROWS NUMCOLUMNS ROWHEIGHT COLWIDTH)) (VLA-SETTEXT OBJTABLE 0 0 "DRAWING REGISTER") (VLA-SETTEXT OBJTABLE 1 0 "DRAWING NUMBER") (VLA-SETTEXT OBJTABLE 1 1 "DRAWING TITLE") (SETQ X 0) (SETQ Y 2) (REPEAT (SSLENGTH SS1) (VLA-SETTEXT OBJTABLE Y 0 (NTH X LIST1)) (VLA-SETTEXT OBJTABLE Y 1 (NTH X LIST2)) (VLA-SETROWHEIGHT OBJTABLE Y 7) (SETQ X (+ X 1)) (SETQ Y (+ Y 1)) ) (VLA-SETCOLUMNWIDTH OBJTABLE 0 55) (VLA-SETCOLUMNWIDTH OBJTABLE 1 170) (COMMAND-S "_ZOOM" "E") ); END AH DEFUN (AH:DWGINDEX) (PRINC) Quote Link to comment Share on other sites More sharing options...
j_spawn_h Posted July 5, 2015 Author Share Posted July 5, 2015 Bigal, that is one of the lisps I found. being I do not know enough about lisps I do not understand how to change it for what I need. Thanks though. If some could tell me what I am looking at maybe I could change it. Quote Link to comment Share on other sites More sharing options...
Tharwat Posted July 5, 2015 Share Posted July 5, 2015 Can you give practical example ? Quote Link to comment Share on other sites More sharing options...
j_spawn_h Posted July 5, 2015 Author Share Posted July 5, 2015 Like this .. Well I can't upload the jpeg so I will try and explain. 3 columns layer name length qty example1 5' 3 example1 2' 5 example2 5' 10 I have a lisp that I can get this info but do not know how to insert into a table. Quote Link to comment Share on other sites More sharing options...
j_spawn_h Posted July 5, 2015 Author Share Posted July 5, 2015 This one by Lee Mac would work. If someone could tell me what is the table info and what is selecting text. I tried inserting part of my in the texts place but no luck. ;;--------------------=={ Text Count }==----------------------;; ;; ;; ;; Counts the number of occurrences of each string in a ;; ;; selection and produces a report in an ACAD Table object ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url] ;; ;;------------------------------------------------------------;; ;; Version 1.0 - 07.11.2010 ;; ;; First Release. ;; ;;------------------------------------------------------------;; ;; Version 1.1 - 05.08.2011 ;; ;; Added Dimensions Override Text & MLeaders ;; ;; Updated 'AddTable' to account for Annotative Text Styles. ;; ;;------------------------------------------------------------;; (defun c:tCount ( /) *error* _StartUndo _EndUndo _Assoc++ _SumAttributes _GetTextString _ApplyFooToSelSet acdoc acspc alist data pt ) ;;------------------------------------------------------------;; (defun *error* ( msg ) (if acdoc (_EndUndo acdoc)) (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) (princ (strcat "\n** Error: " msg " **")) ) (princ) ) ;;------------------------------------------------------------;; (defun _StartUndo ( doc ) (_EndUndo doc) (vla-StartUndoMark doc) ) ;;------------------------------------------------------------;; (defun _EndUndo ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark doc) ) ) ;;------------------------------------------------------------;; (defun _Assoc++ ( key alist ) ( (lambda ( pair ) (if pair (subst (list key (1+ (cadr pair))) pair alist) (cons (list key 1) alist) ) ) (assoc key alist) ) ) ;;------------------------------------------------------------;; (defun _SumAttributes ( entity alist ) (while (not (eq "SEQEND" (cdr (assoc 0 (entget (setq entity (entnext entity)) ) ) ) ) ) (setq alist (_Assoc++ (_GetTextString entity) alist)) ) ) ;;------------------------------------------------------------;; (defun _GetTextString ( entity ) ( (lambda ( string ) (mapcar (function (lambda ( pair ) (if (member (car pair) '(1 3)) (setq string (strcat string (cdr pair))) ) ) ) (entget entity) ) string ) "" ) ) ;;------------------------------------------------------------;; (defun _ApplyFooToSelSet ( foo ss / i ) (if ss (repeat (setq i (sslength ss)) (foo (ssname ss (setq i (1- i)))))) ) ;;------------------------------------------------------------;; (setq acdoc (vla-get-activedocument (vlax-get-acad-object)) acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)) ) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER)))))) (princ "\nCurrent Layer Locked.") ) ( (not (vlax-method-applicable-p acspc 'AddTable)) (princ "\nTable Object not Available in this version.") ) ( (and (setq data (_ApplyFooToSelSet (lambda ( entity / typ ) (setq alist (cond ( (eq "INSERT" (setq typ (cdr (assoc 0 (entget entity))))) (_SumAttributes entity alist) ) ( (eq "MULTILEADER" typ) (_Assoc++ (cdr (assoc 304 (entget entity))) alist) ) ( (wcmatch typ "*DIMENSION") (_Assoc++ (cdr (assoc 1 (entget entity))) alist) ) ( (_Assoc++ (_GetTextString entity) alist) ) ) ) ) (ssget '( (-4 . "<OR") (0 . "TEXT,MTEXT,MULTILEADER") (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>") (-4 . "<AND") (0 . "*DIMENSION") (1 . "*?*") (-4 . "AND>") (-4 . "OR>") ) ) ) ) (setq pt (getpoint "\nSpecify Point for Table: ")) ) (_StartUndo acdoc) (LM:AddTable acspc (trans pt 1 0) "String Count" (cons (list "String" "Instances") (vl-sort (mapcar (function (lambda ( x ) (list (car x) (itoa (cadr x)))) ) data ) (function (lambda ( a b ) (< (car a) (car b)))) ) ) ) (_EndUndo acdoc) ) ) (princ) ) ;;---------------------=={ Add Table }==----------------------;; ;; ;; ;; Creates a VLA Table Object at the specified point, ;; ;; populated with title and data ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url] ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; space - VLA Block Object ;; ;; pt - Insertion Point for Table ;; ;; title - Table title ;; ;; data - List of data to populate the table ;; ;;------------------------------------------------------------;; ;; Returns: VLA Table Object ;; ;;------------------------------------------------------------;; (defun LM:AddTable (space pt title data / _isAnnotative textheight style ) (defun _isAnnotative ( style / object annotx ) (and (setq object (tblobjname "STYLE" style)) (setq annotx (cadr (assoc -3 (entget object '("AcadAnnotative"))))) (= 1 (cdr (assoc 1070 (reverse annotx)))) ) ) ( (lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title) ( (lambda ( row ) (mapcar (function (lambda ( rowitem ) (setq row (1+ row)) ( (lambda ( column ) (mapcar (function (lambda ( item ) (vla-SetText table row (setq column (1+ column)) item) ) ) rowitem ) ) -1 ) ) ) data ) ) 0 ) table ) ( (lambda ( textheight ) (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) textheight (* 0.8 textheight (apply 'max (cons (/ (strlen title) (length (car data))) (mapcar 'strlen (apply 'append data)) ) ) ) ) ) (* 2. (/ (setq textheight (vla-gettextheight (setq style (vla-item (vla-item (vla-get-dictionaries (vla-get-document space)) "ACAD_TABLESTYLE" ) (getvar 'CTABLESTYLE) ) ) acdatarow ) ) (if (_isAnnotative (vla-gettextstyle style acdatarow)) (cond ( (getvar 'CANNOSCALEVALUE) ) ( 1.0 )) 1.0 ) ) ) ) ) ) ;;------------------------------------------------------------;; ;; End of File ;; ;;------------------------------------------------------------;; (and (setq ss (ssget "_:L" '((0 . "LINE")))) (while (setq en (ssname ss 0)) (setq ed (entget en)) (setq p10 (cdr (assoc 10 ed))) (setq p11 (cdr (assoc 11 ed))) (setq lyr (cdr (assoc 8 ed))) (if (= lyr "s-frm-group1")(setq data "GROUP 1")) (ssdel en ss))) Quote Link to comment Share on other sites More sharing options...
BIGAL Posted July 6, 2015 Share Posted July 6, 2015 look at this the first part makes a table, (VLA-SETTEXT OBJTABLE Y 0 (NTH X LIST1)) this puts a value into a row and column given by the Y & X value this example takes a list of values use repeat to get to next, in your case (VLA-SETTEXT OBJTABLE Y 0 value1) if y is 1 then its first row, column 0, (VLA-SETTEXT OBJTABLE Y 1 Value2) this is same row but 2nd column. Dont get confused but it starts with 0. ; untested code but should create a table (SETQ DOC (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) (SETQ CURSPACE (VLA-GET-PAPERSPACE DOC)) (SETQ PT1 (VLAX-3D-POINT (GETPOINT "\NPICK POINT FOR TOP LEFT HAND OF TABLE: "))) ; NOW DO TABLE (SETQ NUMROWS 4)) (SETQ NUMCOLUMNS 2) (SETQ ROWHEIGHT 0.2) (SETQ COLWIDTH 150) (SETQ OBJTABLE (VLA-ADDTABLE CURSPACE PT1 NUMROWS NUMCOLUMNS ROWHEIGHT COLWIDTH)) (VLA-SETTEXT OBJTABLE 0 0 "DRAWING REGISTER") ; this top level (VLA-SETTEXT OBJTABLE 1 0 "DRAWING NUMBER") ; 2nd line down 1st column (VLA-SETTEXT OBJTABLE 1 1 "DRAWING TITLE") ; 2nd line down second column ; and this (SETQ X 0) (SETQ Y 2) (REPEAT 4 (VLA-SETTEXT OBJTABLE Y 0 "value1") (VLA-SETTEXT OBJTABLE Y 1 "value2") (VLA-SETROWHEIGHT OBJTABLE Y 7) (SETQ X (+ X 1)) (SETQ Y (+ Y 1)) ) Quote Link to comment Share on other sites More sharing options...
j_spawn_h Posted July 10, 2015 Author Share Posted July 10, 2015 Tharwat I found this lisp you wrote for circles. If it could pull line info out it would work great for what I need. layer name length qty example1 5' 3 example1 2' 5 example2 5' 10 (defun c:Test (/ hgt spc d dia e ents inc increment Layers insertionPoint tbl lengths lst r selectionset integer selectionsetname ) (vl-load-com) ;;; Tharwat 21 . June . 2012 ;;; (if (not acdoc) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) ) (setq spc (if (> (vla-get-activespace acdoc) 0) (vla-get-modelspace acdoc) (vla-get-paperspace acdoc) ) ) (setq hgt (if (zerop (cdr (assoc 40 (setq e (entget (tblobjname "STYLE" (getvar 'textstyle))) ) ) ) ) (cdr (assoc 42 e)) (cdr (assoc 40 e)) ) ) (setq increment 1) (if (setq selectionset (ssget (list '(0 . "CIRCLE")))) (progn (repeat (setq integer (sslength selectionset)) (setq selectionsetname (ssname selectionset (setq integer (1- integer)) ) ) (setq dia (cons (cons (* (cdr (assoc 40 (entget selectionsetname))) 2.) (itoa increment) ) dia ) ) (setq ents (cons selectionsetname ents)) (setq increment (1+ increment)) ) ) ) (if (and dia (setq insertionPoint (getpoint "\n Specify Table Location :")) ) (progn (setq tbl (vla-addtable spc (vlax-3d-point insertionPoint) (+ (length dia) 2) 2 (* hgt 2.5) (* hgt 2.5) ) ) (setq inc -1 r 1 ) (repeat 2 (vla-setcolumnwidth tbl 0 (* hgt 10.)) (vla-setcolumnwidth tbl 1 (* hgt 10.)) (vla-setrowheight tbl (setq inc (1+ inc)) (* hgt 1.5)) ) (vla-settext tbl 0 0 "Circle's Diameters") (vla-settext tbl 1 0 "Reference No.") (vla-settext tbl 1 1 "Diameter Value") (foreach x (reverse dia) (vla-settext tbl (setq r (1+ r)) 0 (cdr x)) (vla-setcellalignment tbl r 0 acMiddleCenter) (vla-settext tbl r 1 (rtos (car x) 2)) (vla-setcellalignment tbl r 1 acMiddleCenter) ) (setq increment 1) (foreach p (reverse ents) (setq d (* (cdr (assoc 40 (entget p))) 2.)) (entmakex (list '(0 . "TEXT") (assoc 10 (entget p)) (cons 11 (cdr (assoc 10 (entget p)))) (cons 40 (if (> increment 9) (/ d 1.5) (if (> hgt d) d hgt ) ) ) (cons 1 (itoa increment)) '(72 . 1) '(73 . 2) ) ) (setq increment (1+ increment)) ) ) ) (princ "\n Written by Tharwat Al Shoufi") (princ)) Quote Link to comment Share on other sites More sharing options...
Tharwat Posted July 11, 2015 Share Posted July 11, 2015 A quick modification on the table codes . (defun Table (lst / acdoc hgt d inc p e tbl r c) ;;; Tharwat 11 . July . 2015 ;;; (if (and lst (setq p (getpoint "\n Specify Table Location :")) ) (progn (setq acdoc (vla-get-activedocument (vlax-get-acad-object)) hgt (if (zerop (cdr (assoc 40 (setq e (entget (tblobjname "STYLE" (getvar 'textstyle)) ) ) ) ) ) (cdr (assoc 42 e)) (cdr (assoc 40 e)) ) tbl (vla-addtable (vla-get-block (vla-get-activelayout acdoc)) (vlax-3d-point p) (+ (length lst) 2) 3 (* hgt 2.5) (* hgt 2.5) ) inc -1 r 1 ) (vla-settext tbl 0 0 "Summary") (vla-settext tbl 1 0 "Layer Name") (vla-setcolumnwidth tbl 0 (* hgt 8.)) (vla-settext tbl 1 1 "Length") (vla-setcolumnwidth tbl 1 (* hgt 6.)) (vla-settext tbl 1 2 "QTY") (vla-setcolumnwidth tbl 2 (* hgt 4.)) (mapcar '(lambda (i) (vla-setrowheight tbl i (* hgt 1.5))) '(0 1)) (foreach v lst (setq c -1 r (1+ r) ) (foreach x v (vla-settext tbl r (setq c (1+ c)) x) (vla-setrowheight tbl r (* hgt 1.5)) (vla-setcellalignment tbl r c acMiddleCenter) ) ) ) ) (princ) )(vl-load-com) Usage: (Table '(("a" "b" 1) ("c" "d" 2) ("e" "f" 3))) Quote Link to comment Share on other sites More sharing options...
j_spawn_h Posted July 18, 2015 Author Share Posted July 18, 2015 Tharwat, Thank you for adjusting the code, but I do not no enough to make it work for me. I found this code for polylines and did some modifications. But I still can't get what I need. I got the 3 columns I want. But I do not know how to make it add the same product up in 1 row and also keep the rows adding per how many products I picked. layer name length qty example1 5' 3 example1 2' 5 example2 5' 10 (vl-load-com) (defun C:mat ( / *MS* A CNT I LST MYTABLE PT1 ROW SSET TLST) ; create an empty list, set a counter variable, and ; set a reference to the current model space. (setq lst '() i 0 *ms* (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ) ; prompt the user to select lines (princ "\n Select closed lines ") (if (setq sset (ssget "_:L" '((0 . "LINE");(-4 . "&") ;(70 . 1) ))) (progn (setq en (ssname sset 0)) (setq ed (entget en)) (setq k (sslength sset)) (setq p10 (cdr (assoc 10 ed))) (setq p11 (cdr (assoc 11 ed))) (setq lyr (cdr (assoc 8 ed))) (setq depth (cdr (assoc 39 ed))) (setq mpt (mapcar '(lambda (a b) (* (+ a b) 0.5)) p10 p11)) (setq d2d (distance (cdr (reverse p10)) (cdr (reverse p11)))) (setq d1d (/ d2d 12.)) (setq d1c (fix d1d)) (if (> d1d d1c) (setq d2c (+ d1c 1))) (if (<= d1d d1c) (setq d2c d1c)) (if (= lyr "s-frm-blk")(setq lyr2 "BLK")) (if (= lyr "S-FRM-BLK")(setq lyr2 "BLK")) ; and store these values in a list. (repeat (setq cnt (sslength sset)) (setq a (vlax-ename->vla-object (ssname sset i))) (setq tlst (list (vla-get-length a) (vla-get-ObjectID a))) (setq lst (cons tlst lst)) (setq i (1+ i)) ) ; pick a point for the table (setq pt1 (getpoint "\nPick point for table ")) ; add the new table (setq myTable (vla-AddTable *ms* (vlax-3d-point pt1) (+ 3 cnt) 3 0.7 2.5)) ; the next three lines set the header text (vla-setText mytable 0 0 "Title") (vla-setText mytable 1 0 "Length") (vla-setText mytable 1 1 "Product") (vla-setText mytable 1 2 "Qty") (setq row 2) ; loop through the list of line properties ; adding a line to the table that contains the ; area and the length (foreach item lst (vla-setText mytable row 0 (strcat "%<[url="file://\\AcObjProp"]\\AcObjProp[/url] Object(%<\_ObjId " (itoa (last item)) ">%).Length [url="file://\\f"]\\f[/url] \"%lu4\">%")) ; (itoa d2c) ) (vla-setText mytable row 1 (last item)) (setq row (1+ row)) ) ; product (foreach item lst (vla-setText mytable row 1 (setq tch (strcat lyr2))) (vla-setText mytable row 1 (last item)) (setq row (1+ row))) ;(strcat "Total=\\P" ;"%<[url="file://\\AcExpr"]\\AcExpr[/url] (Sum(A3:A" (itoa (+ 2 cnt)) ")) [url="file://\\f"]\\f[/url] \"%lu2\">%")) ; release "myTable" and *ms* (vlax-release-object myTable) (vlax-release-object *ms*) ); end progn ); end if (princ) ); end defun Quote Link to comment Share on other sites More sharing options...
Tharwat Posted July 18, 2015 Share Posted July 18, 2015 Coding is not a matter of copying and pasting. Quote Link to comment Share on other sites More sharing options...
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.