Lisp to count attributes

[tazzzz]

Hello all,

I found this lisp on a different forum. First of all, this is the work of fixo (thanks for your generosity in making available this lisp).

This program will work like Dataextraction only much more easy to create tables.

I need your help in changing this lisp in order to perform the same thing but without having an attribute QTY inside the block(QTY needs to be always 1 and it is so easy to input something else) Perhaps assuming that all selected blocks have QTY=1

I tried to go around and make the attribute QTY as a constant but the lisp will not read it.

Thank you for your help.

 

(defun C:COUNTATT(/ acapp acol acsp adoc atable attdata attitem atts blkdata blkname blkobj col
       column colwidth  datalist en headers pt row sset swap  tabledata tags total txtheight widths x)
 
 ;private function

 (defun sum-and-groupby-three (lst / groups res sum tmp)
 (while lst
   (setq tmp        (car lst)
     sum
           (apply '+
              (mapcar 'atoi (mapcar 'cdadr 
                  (setq res (vl-remove-if-not

                          '(lambda (a) (and
                                 (eq (cdr (nth 0 a)) (cdr (nth 0 tmp)))
                                 (eq (cdr (nth 1 a)) (cdr (nth 1 tmp)))
                                 (eq (cdr (nth 2 a)) (cdr (nth 2 tmp)))))

                          lst

                        )
                  )
              ))
           )
     groups    (cons (subst (cons "QTY" (itoa sum))(cadr tmp) tmp) groups)
     lst
           (vl-remove-if
             '(lambda (a) (member a res))

             lst

           )
   )
 )

(reverse groups)
)

;            main part            ;
 (if (setq sset (ssget (list (cons 0 "INSERT") (cons 66 1))))
   (progn
     (setq tabledata nil
       attdata nil
       attitem nil
     )
     
     (while (setq en (ssname sset 0))
   (setq blkobj  (vlax-ename->vla-object en)
         blkname (vla-get-effectivename blkobj)
   )
   (setq atts (vlax-invoke blkobj 'getattributes))
   (foreach attobj    atts

         (setq attitem (cons (vla-get-tagstring attobj) (vla-get-textstring attobj)))
         (setq attdata (cons attitem attdata))

   )

   (setq tabledata (cons (reverse attdata) tabledata))
   (setq attdata nil
         attitem nil
   )
   (ssdel en sset)
     )
(setq headers (mapcar 'car (car tabledata))
       tags    headers 
     )
(setq tabledata (sum-and-groupby-three tabledata))

(setq tabledata (mapcar '(lambda (x)
                (mapcar 'cdr x)
                  )
                 tabledata
             )
     )


     ;; sort by "A1" :
     
    (setq tabledata (vl-sort   tabledata '(lambda(a b)(< (car a)(car b)))))


     (setq total 0)
     (foreach i datalist (setq total (+ total (cdr i))))
   (initget 6)
 (setq txtheight (getreal "\nSpecify Text height for the table <50>:"))
 (cond ((not txtheight)(setq txtheight 50))) ;<-- text height as for as in your drawing

      (or adoc (setq adoc (vla-get-activedocument (setq acapp (vlax-get-acad-object)))))
     (or acsp (setq acsp (vla-get-block (vla-get-activelayout adoc))))
(setq acCol (vla-GetInterfaceObject acapp(strcat "AutoCAD.AcCmColor." (itoa(atoi(getvar "acadver"))))))
     (setq pt (getpoint "\nSpecify table location:"))
     (setq atable (vla-addtable
            acsp
            (vlax-3d-point pt)
            (+ 2 (length tabledata))
            (length headers)
            (* txtheight 1.2)
            (* txtheight 20)
          )
     )
     (vla-put-regeneratetablesuppressed atable :vlax-true)
      ;; calculate column widths : 
     (setq swap (append (list headers) tabledata)
       widths nil)
     (while (car swap)
   (setq column (mapcar 'car swap))
   (setq colwidth (* 1.2 (apply 'max (mapcar 'strlen column))txtheight))
   (setq widths (cons colwidth widths))
   (setq swap (mapcar 'cdr swap)))

     (setq widths (reverse widths))
      ;; set column widths
      (setq col 0)
      (foreach wid widths
        (vla-setcolumnwidth atable col wid)
        (setq col (1+ col))
        )
     (vla-put-horzcellmargin atable (* txtheight 0.5))
     (vla-put-vertcellmargin atable (* txtheight 0.3))
     (vla-setTextheight atable 1 txtheight)
     (vla-setTextheight atable 2 txtheight)
     (vla-setTextheight atable 4 txtheight)
     (vla-setText atable 0 0 "ATTRIBUTE SUMMARY")
     (vla-SetCellAlignment atable 0 0 acMiddleCenter)
           (vla-put-colorindex accol 2)
(vla-setcellcontentcolor atable 0 0 accol)
     (setq col -1)
     (foreach descr headers
   (vla-setText atable 1 (setq col (1+ col)) descr)
   (vla-SetCellAlignment atable 1 col acMiddleCenter)
   (vla-setcellcontentcolor atable 1 col accol)
     )
     
       (vla-put-colorindex accol 4)
     
      (setq row 2)
     
     (foreach record tabledata

   (setq col 0)
   (foreach item record
     (vla-setText atable row col item)
     (if (= 1 col)
     (vla-SetCellAlignment atable row col acMiddleCenter)
     (vla-SetCellAlignment atable row col acMiddleLeft)
          )
     (vla-setcellcontentcolor atable row col accol)
     (setq col (1+ col))
   )
   (setq row (1+ row))
     )
(vla-put-width atable (apply '+ widths))
     (vla-put-height atable (* 1.2 (vla-get-rows atable)txtheight))
     (vla-put-regeneratetablesuppressed atable :vlax-false)

   )
 )
(if  accol (vlax-release-object accol))
(if  acapp (vlax-release-object acapp))
(princ)
)
(prompt "\n\t---\tStart command with COUNTATT\t---\n")
(prin1)
(or (vl-load-com))
(princ)

Attribute counter.dwg