Message 1 of 3
Count Attributes of specific Blocks
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
HI
What I Need:
Look for specifics Blocks and Mleader with Block.
Check the Attribute Pos. (type of element for example 12B) and count how many lengths there are for this Pos.
Then create a table with this Information:
Pos. 83cm 125cm
12B 30 26
19 12 14
I have 6 Blocks: Mleader with length 83+125cm / Mleader with only 83cm / Mleader with only 125cm / Text 83+125cm / Text only 83cm / Text only 125cm.
The following code is working in this direction, but still does not what i want.
Please help me with it :)...
(vl-load-com)
(defun c:COUNTATT (/ acapp acol acsp adoc atable attdata attitem atts blkdata blkname blkobj col
column colwidth datalist en headers pt row ss swap tabledata tags total txtheight widths x)
;; Lee Mac
;; http://www.lee-mac.com/attributefunctions.html
(defun LM:vl-getattributes ( blk )
(mapcar '(lambda (att) (cons (vla-get-tagstring att) (vla-get-textstring att)))
(vlax-invoke blk 'getattributes)))
;; Lee Mac
;; https://www.theswamp.org/index.php?topic=46547.0
(defun LM:vl-getmleaderatts ( obj / rtn )
(if (and (= "AcDbMLeader" (vla-get-objectname obj))
(= acblockcontent (vla-get-contenttype obj)))
(vlax-for sub (vla-item (vla-get-blocks (vla-get-document obj))
(vla-get-contentblockname obj))
(if (= "AcDbAttributeDefinition" (vla-get-objectname sub))
(setq rtn (cons (cons (vla-get-tagstring sub)
(vla-getblockattributevalue obj (LM:objectid sub)))
rtn)))))
(reverse rtn))
;; ObjectID - Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems
(defun LM:objectid ( obj )
(eval (list 'defun 'LM:objectid '(obj)
(if (and (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
(vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring))
(list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
'(itoa (vla-get-objectid obj)))))
(LM:objectid obj))
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc))
(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))
; ----------------------------------------------------------------------------------------------------------------------------
; ----------------------------------------------------------------------------------------------------------------------------
(if (setq ss (ssget '((-4 . "<OR")
(-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>")
(0 . "MULTILEADER") (-4 . "OR>"))))
(progn
(repeat (setq i (sslength ss))
(setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i))))
tabledata (cons (if (= "AcDbMLeader" (vla-get-objectname obj))
(LM:vl-getmleaderatts obj)
(LM:vl-getattributes obj))
tabledata)))
(print tabledata)
(setq headers (mapcar 'car (car tabledata))
tags headers
tabledata (sum-and-groupby-three tabledata)
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 (cond ((getreal "\nSpecify Text height for the table <50>: "))
(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:")
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)
colwidth (* 1.2 (apply 'max (mapcar 'strlen column)) txtheight)
widths (cons colwidth widths)
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")
(princ)
