Comslab Table Floor Bay Quantity Length Rebar Gauge 3 2e 11 20'-1 1/4" #5 19 3 2d 5 9'-9" #5 19 3 2c 2 9'-5 3/4" #5 19 3 1f 3 22'-0 1/2" #5 19 3 1e 11 20'-10 1/4" #5 19 3 1d 4 9'-4 1/2" #5 19 3 1d 1 9'-4 3/4" #5 19 3 1c 2 9'-1 1/4" #5 19 2 2e 11 20'-1 1/4" #5 19 2 2d 5 9'-9" #5 19 2 2c 2 9'-5 3/4" #5 19 2 1f 3 22'-0 1/2" #5 19 2 1e 11 20'-10 1/4" #5 19 2 1d 4 9'-4 1/2" #5 19 2 1d 1 9'-4 3/4" #5 19 2 1c 2 9'-1 1/4" #5 19 2 2b 4 18'-4" #5 19 2 1b 4 14'-2 1/4" #5 19 2 2a 11 20'-1 1/4" #5 19 2 1a 11 20'-10 1/4" #5 19 1 1d 4 4'-8 1/4" #5 19 1 1c 4 9'-7 3/4" #5 19 1 1b 3 32'-4 1/4" #5 19 1 1a 4 18'-2 3/4" #5 19 |
(defun c:rn_lstatt (/ choix doc i js ent fic fil lab lst mrc trc n nb nm nombl InputBox liste_att mrech rechercher_nom s sel tbl trier txt *errlst*)
(defun *errlst* (msg)
(or (member (strcase msg) '("FUNCTION CANCELLED" ""QUIT / EXIT ABORT"" "FONCTION ANNULEE" "QUITTER / SORTIR ABANDON"))
(princ (strcat "\nErreur : " msg))
)
(setq *error* s)
(princ)
)
(defun nombl(bl)
(if (vlax-property-available-p bl 'effectivename)
(vla-get-effectivename bl)
(vla-get-name bl)
)
)
; (defun choix(/ bl js lst nom sel)
; (princ "\nSйlectionnez le(s) bloc(s) а dйnombrer : ")
; (and (ssget (list (cons 0 "insert")))
; (progn
; (vlax-for bl (setq sel (vla-get-activeselectionset doc))
; (or (member (setq nom (nombl bl)) lst)
; (setq lst (cons nom lst))
; )
; (redraw (vlax-vla-object->ename bl) 4)
; )
; (foreach nom lst
; (if js
; (setq js (strcat js "," nom))
; (setq js nom)
; )
; )
; (vla-delete sel)
; )
; )
; js
; )
(defun InputBox (Titre js / ch dcl fil res tmp txt)
; (setq tmp (vl-filename-mktemp "lstatt" nil ".dcl")
; fil (open tmp "w")
; )
; (foreach txt '( "lstatt : dialog {"
; " key = \"titre\";"
; " alignment = centered;"
; " is_cancel = true;"
; " allow_accept = true;"
; " width = 30;"
; " : boxed_column {"
; " label = \"Veuillez donner un nom de bloc ou * pour tous\";"
; " : row {"
; " : edit_box {key = \"filtre\";width = 45;}"
; " : button {key = \"choix\"; label = \">>\";}"
; " }"
; " spacer;"
; " }"
; " : boxed_column {"
; " label = \"Nombre d'attributs а prendre en compte\"; "
; " : edit_box {key= \"att\";}"
; " spacer;"
; " }"
; " spacer;"
; " : toggle {key = \"fic\"; label = \"Ecrire les rйsultats dans un fichier\";}"
; " : toggle {key = \"lab\"; label = \"Ajouter le nom des йtiquettes dans les rйsultats\";}"
; " spacer;"
; " ok_cancel;"
; "}"
; )
; (write-line txt fil)
; )
; (close fil)
; (setq dcl (load_dialog tmp))
; (while (not (member res '(0 1)))
; (new_dialog "lstatt" dcl "")
; (set_tile "titre" titre)
; (set_tile "filtre" js)
; (set_tile "att" nb)
; (set_tile "fic" fic)
; (set_tile "lab" lab)
; (action_tile "filtre" "(setq js $value)")
; (action_tile "choix" "(done_dialog 2)")
; (action_tile "att" "(setq nb $value)")
; (action_tile "fic" "(setq fic $value)")
; (action_tile "lab" "(setq lab $value)")
; (action_tile "accept" "(done_dialog 1)")
; (action_tile "cancel" "(done_dialog 0)")
; (setq res (start_dialog))
; (and (eq res 2)
(setq ch "Plan Slab")
(setq js ch)
; )
; )
; (unload_dialog dcl)
; (vl-file-delete tmp)
; (if (member res '(1 2))
; js
; ""
; )
)
(defun liste_att(att / n lst val)
; (if (< (atoi nb) (length att))
(progn
(setq n 0)
(while (and (< n (atoi nb)) (setq val (nth n att)))
(setq lst (cons (if (eq lab "0")
(vla-get-textstring (nth n att))
(strcat (vla-get-tagstring (nth n att)) ":" (vla-get-textstring (nth n att)))
)
lst
)
n (1+ n)
)
)
(setq lst (reverse lst))
(setq lst (remove-i 11 lst))
(setq lst (remove-i 10 lst))
(setq lst (remove-i 9 lst))
(setq lst (remove-i 8 lst))
(setq lst (remove-i 7 lst))
(setq lst (remove-i 6 lst))
(setq lst (remove-i 5 lst))
(setq lst (remove-i 4 lst))
(setq lst (remove-i 3 lst))
)
; (if (eq lab "0")
; (mapcar 'vla-get-textstring att)
; (mapcar '(lambda(x)(strcat (vla-get-tagstring x) ":" (vla-get-textstring x))) att)
; )
; )
)
(defun rechercher_nom(val / att nom tbl)
(setq nom (nombl val))
(if (eq (vla-get-hasattributes val) :vlax-true)
(if (member (setq att (vlax-invoke val 'getattributes)) '(nil))
(list nom)
(cons nom (liste_att att))
)
(list nom)
)
)
; (defun trier(a b / c n s)
; (setq c 0)
; (while (and (not s) (nth c a))
; (if (eq (nth c a) (nth c b))
; (setq c (1+ c))
; (setq s T)
; )
; )
; (or (nth c a) (setq c 0))
; (< (strcase (nth c a)) (strcase (nth c b)))
; )
(defun mrech(bl / ent lst recu)
(defun recu(bl)
(vlax-for ent (vla-item (vla-get-blocks doc) (nombl bl))
(and (eq (vla-get-objectname ent) "AcDbBlockReference")
(if (eq (substr (nombl ent) 1 1) "*")
(recu ent)
(setq lst (cons ent lst))
)
)
)
)
(and (eq (substr (nombl bl) 1 1) "*")
(recu bl)
)
lst
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vl-load-com)
(setq s *error*
*error* *errlst*
doc (vla-get-activedocument (vlax-get-acad-object))
)
(setq nb "14"); set the limit of attributes needed to be collected from the block
(setq lab "0"); set lab
(setq fic "0")
(if (not (eq (setq nm (InputBox "Dйcompte de blocs V4.21" "*")) ""))
(progn
(setq js (strcat "`**," nm))
(if (ssget (list (cons 0 "INSERT") (cons 2 js)))
(progn
;(setenv "Patrick_35_nb_att" nb)
;(setenv "Patrick_35_nb_lab" lab)
(vlax-map-collection (setq sel (vla-get-activeselectionset doc))
'(lambda (x)
(if (setq trc (mrech x))
(foreach mrc trc
(if (wcmatch (strcase (car (setq js (rechercher_nom mrc)))) (strcase nm))
(setq tbl (cons js tbl))
)
)
(if (wcmatch (strcase (car (setq js (rechercher_nom x)))) (strcase nm))
(if (eq (vla-get-objectname x) "AcDbMInsertBlock")
(repeat (* (vla-get-columns x) (vla-get-rows x))
(setq tbl (cons js tbl))
)
(setq tbl (cons js tbl))
)
)
)
)
)
(vla-delete sel)
(while tbl
(setq n (length tbl)
js (car tbl); js = ("Plan Slab" "2" "2d")
tbl (vl-remove js tbl)
lst (cons
(rearragneslablist (remove-i 1 (cons (itoa (- n (length tbl))) js))) lst
); lst =(("1" "Plan Slab" "2" "2d"))
)
)
;printing into command line
; (if lst
; (progn
; (and (eq fic "1")
; (setq fil (open (setq txt (strcat (getvar "dwgprefix") (vl-filename-base (getvar "dwgname")) ".txt")) "w"))
; )
; (foreach n (vl-sort lst '(lambda (a b) (trier (cdr a) (cdr b))))
; (if (eq fic "1")
; (princ (strcat (car n) (chr 9) (cadr n)) fil)
; (princ (strcat "\n"
; (substr " " 1 (- 5 (strlen (car n))))
; (car n)
; " "
; (cadr n)
; )
; )
; )
; (setq i 2)
; (while (setq val (nth i n))
; (if (eq fic "1")
; (princ (strcat (chr 9) val) fil)
; (princ (strcat " " val));...
; )
; (setq i (1+ i))
; )
; (and (eq fic "1")
; (write-line "" fil)
; )
; )
; (and (eq fic "1")
; (princ (strcat "\nFichier \"" txt "\" crйй."))
; (close fil)
; )
; )
; (princ "\nPas de bloc а dйnombrer.")
; )
)
)
)
)
(setq *error* s)
(princ)
(setq space
(vlax-get-property
(setq doc
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
)
)
(setq pt (getpoint "\nPick Point for Table: "))
(LM:AddTable space (trans pt 1 0) "Comslab Table"
(cons '("Floor" "Bay" "Quantity" "Length" "Rebar" "Gauge") lst)
)
)
;(setq nom_lisp "LSTATT")
;(if (/= app nil)
; (if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)
; (princ (strcat "..." nom_lisp " chargй."))
; (princ (strcat "\n" nom_lisp ".LSP Chargй.....Tapez " nom_lisp " pour l'йxecuter.")))
; (princ (strcat "\n" nom_lisp ".LSP Chargй......Tapez " nom_lisp " pour l'йxecuter.")))
;(setq nom_lisp nil)
;(princ)
;;---------------------=={ Add Table }==----------------------;;
;; ;;
;; Creates a VLA Table Object at the specified point, ;;
;; populated with title and data ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; 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 / _itemp ) (vl-load-com)
(defun _itemp ( collection item )
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply 'vla-item (list collection item))
)
)
)
item
)
)
(
(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)) (* 1.8 textheight)
(* textheight
(apply 'max
(cons (/ (strlen title) (length (car data)))
(mapcar 'strlen (apply 'append data))
)
)
)
)
)
(vla-getTextHeight
(_itemp
(_itemp
(vla-get-Dictionaries
(vla-get-ActiveDocument (vlax-get-acad-object))
)
"ACAD_TABLESTYLE"
)
(getvar 'CTABLESTYLE)
)
acDataRow
)
)
)
)
;;;
(defun remove-i (i lst)
;;; i - index (fom 0)
;;;lst- list of elemets
(setq i (1+ i))
(vl-remove-if '(lambda (x) (zerop (setq i (1- i)))) lst)
) ;_ end of defun
(defun rearragneslablist (lst / first thelast lst2 lst3)
(setq
first (nth 0 lst)
thelast (nth 5 lst)
lst2 (remove-i 0 lst)
lst2 (remove-i 2 lst2)
lst2 (remove-i 2 lst2)
lst2 (remove-i 2 lst2)
lst (remove-i 0 lst)
lst (remove-i 0 lst)
lst (remove-i 0 lst)
lst (cons first lst)
lst (append lst2 lst)
lst (remove-i 5 lst)
lst3 (remove-i 3 lst)
lst3 (remove-i 3 lst3)
lst (remove-i 0 lst)
lst (remove-i 0 lst)
lst (remove-i 0 lst)
lst (cons thelast lst)
lst (append lst3 lst)
)
)
(setq lst (vl-sort lst
(function (lambda (A B)
(< (cadr A) (cadr B)))))
lst (vl-sort lst
(function (lambda (A B)
(< (car A) (car B)))))
)
(foreach i lst
(if (= (car i) <floor string>)
(setq tlist (cons i tlist))
)
)
Then you could use the variable 'tlist', as that is now the list of only the floor you wanted.(("1" "4" "18'-2 3/4\"" "#5" "19") ("2" "11" "20'-10 1/4\"" "#5" "19") ("3" "2" "9'-1 1/4\"" "#5" "19"))
(("1" "4" "18'-2 3/4\"" "#5" "19" "72' 11\"") ("2" "11" "20'-10 1/4\"" "#5" "19" "229' 43/4\"") ("3" "2" "9'-1 1/4\"" "#5" "19" "18' 21/2\""))
(defun testit()
(mapcar '(lambda (n) (reverse (cons (rtos (* (read (cadr n)) (read (caddr n))) 2 2) (reverse n))))
'(("1" "4" "18.50" "#5" "19") ("2" "11" "20.25" "#5" "19") ("3" "2" "9.50" "#5" "19"))))
(("1" "#5" "19" "225") ("1" "#5" "19" "463") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5"))
(("1" "#5" "19" "1852.75") ("2" "#5" "19" "3238,75") ("3" "#5" "19" "3466.25"))
(setq lst '(("1" "#5" "19" "225") ("1" "#5" "19" "463") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5")))
(foreach i lst
(if (setq item (assoc (car i) tlist))
(setq tlist
(subst
(subst (rtos (+ (distof (cadddr i)) (distof (cadddr item)))) (cadddr item) item)
item
tlist
)
)
(setq tlist (cons i tlist))
)
)
Command: (rtos 18.5 5 2)
"18 1/2"
Command: (read (rtos 18.5 5 2))
18
Command: (distof (rtos 18.5 5 2))
18.5
(defun summassoclasts ( l / removenth massoc groupbycar i ll )
(defun removenth ( n l / k ll )
(setq k -1)
(foreach i l
(setq k (1+ k))
(if (/= k n)
(setq ll (cons i ll))
)
)
(reverse ll)
)
(defun massoc ( key lst / i nlst )
(while (setq i (assoc key lst))
(setq nlst (cons i nlst))
(setq lst (removenth (vl-position i lst) lst))
)
(reverse nlst)
)
(defun groupbycar ( l / i ll lll )
(while (setq i (car l))
(setq ll (massoc (car i) l))
(foreach ii ll
(setq l (removenth (vl-position ii l) l))
)
(setq lll (cons ll lll))
)
(reverse lll)
)
(foreach g (groupbycar l)
(setq i (car g))
(setq i (reverse (cons (rtos (apply '+ (mapcar 'atof (mapcar 'last g)))) (cdr (reverse i)))))
(setq ll (cons i ll))
)
(reverse ll)
)
Thanks Tim,
I see what he wants now :)
ribarm Your version returned the same initial list.
;;; (setq l '(("1" "#5" "19" "225") ("1" "#5" "19" "463") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5")))
;;; (summassoclasts l) => (("1" "#5" "19" "1852.75000000") ("2" "#5" "19" "3238.75000000") ("3" "#5" "19" "3466.25000000"))
(defun summassoclasts ( l / removenth 3keyassoc massoc groupby3keys i ll )
(defun removenth ( n l / k ll )
(setq k -1)
(foreach i l
(setq k (1+ k))
(if (/= k n)
(setq ll (cons i ll))
)
)
(reverse ll)
)
(defun 3keyassoc ( 3keylst lst / i )
(vl-some '(lambda ( x ) (if (and (= (car x) (car 3keylst)) (= (cadr x) (cadr 3keylst)) (= (caddr x) (caddr 3keylst))) (setq i x))) lst)
i
)
(defun massoc ( 3keylst lst / i nlst )
(while (setq i (3keyassoc 3keylst lst))
(setq nlst (cons i nlst))
(setq lst (removenth (vl-position i lst) lst))
)
(reverse nlst)
)
(defun groupby3keys ( l / i ll lll )
(while (setq i (car l))
(setq ll (massoc (list (car i) (cadr i) (caddr i)) l))
(foreach ii ll
(setq l (removenth (vl-position ii l) l))
)
(setq lll (cons ll lll))
)
(reverse lll)
)
(foreach g (groupby3keys l)
(setq i (car g))
(setq i (reverse (cons (rtos (apply '+ (mapcar 'atof (mapcar 'last g)))) (cdr (reverse i)))))
(setq ll (cons i ll))
)
(reverse ll)
)
;;; (setq l '(("1" "#5" "19" "225") ("1" "#7" "19" "560") ("1" "#5" "19" "463") ("1" "#7" "19" "755") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("2" "#5" "16" "153.75") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5")))
;;; (summassoclasts l) => (("1" "#5" "19" "1852.75000000") ("1" "#7" "19" "1315.00000000") ("2" "#5" "19" "3238.75000000") ("2" "#5" "16" "153.75000000") ("3" "#5" "19" "3466.25000000"))
By the way, Lee Mac, I am using your function LM:AddTable to write list into table. It is very useful for amateurs like me. It is aligning width of all the columns to the widest content of any column. Sometimes it is the best, but sometimes, if you have one column with content significantly wider than the others, this is not the best choice and I would rather have them all with a unique width in accordance to the width if it's content. Do you have this kind of modification of LM:AddTable?
Thanks. It works. Just added list before rtos to eliminate the point in between. :)