;;Counting rectangles.

;;Stefan M., 11.feb.2015

;;color counting 04.mar.2015
;;color order 26.may.2016
(defun rectangle_dims (e / l a b)
(setq l (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) e)))
(if
(and
(or
(= 1 (logand (cdr (assoc 70 e)) 1))
(equal (car l) (last l) 1e-8)
)
(equal (distance (car l) (caddr l)) (distance (cadr l) (cadddr l)) 1e-
8)
(equal (mapcar '- (cadr l) (car l)) (mapcar '- (caddr l) (cadddr l)) 1e-
8)
(equal (mapcar '- (caddr l) (cadr l)) (mapcar '- (cadddr l) (car l)) 1e-
8)
)
(vl-sort (list (distance (car l) (cadr l)) (distance (cadr l) (caddr l))) '<)
)
)

(defun C:RECDIMS (/ *error* ss e old r p1 c col_order sh)

(vl-load-com)
(setq acObj (vlax-get-acad-object)
acDoc (vla-get-activedocument acObj)
space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
)
(vla-startundomark acDoc)

;;;;;; Error function ;;;;;;;;;

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
(princ (strcat "\nError: " msg))
)
(vla-endundomark acDoc)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if
(setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (90 . 4) (90 . 5) (-4 .
"OR>"))))
(progn
(setq col_order ; list of color position in the table. List format (color
position)
'(( 2 1) ( 34 2) ( 7 3) (252 4) (173 5) ( 8 6) (254 7)
(221 8)
( 48 9) (165 10) (255 11) ( 10 12) ( 16 13) ( 62 14) (108 15)
(130 16)
(134 17) (151 18) ( 90 19) ( 94 20) ( 30 21) (245 22) ( 6 23)
(192 24)
(198 25) (216 26) (236 27) ( 51 28) ( 52 29) (152 30) ( 93 31)
(170 32))
sh (length col_order)
)
 (repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
c (cond
((cdr (assoc 62 (entget e))))
((cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 (entget e)))))))
)
c (if (zerop c) 7 c)
)
(if
(and
(setq dims (rectangle_dims (entget e)))
(setq dims (cons c dims))
)
(if
(setq old (vl-some '(lambda (d) (if (equal (cdr d) dims 1e-8) d)) r))
(setq r (subst (cons (1+ (car old)) dims) old r))
(setq r (cons (cons 1 dims) r))
)
)
)
(if
(and r (setq p1 (getpoint "\nSpecify table insert point: ")))
(insert_table
(vl-sort
(vl-sort
(vl-sort
(mapcar '(lambda (a) (list (cadr a) (caddr a) (cadddr a) (car a)))
r)
'(lambda (a b) (< (caddr a) (caddr b)))
)
'(lambda (a b) (< (cadr a) (cadr b)))
)
'(lambda (a b / c)
(<
(if
(setq c (assoc (car a) col_order))
(cadr c)
(+ sh (car a))
)
(if
(setq c (assoc (car b) col_order))
(cadr c)
(+ sh (car b))
)
)
)
)
p1
)
)
)
)
(princ)
)

;;The textheight in table depends on cannonscale

(defun insert_table (lst pct / tab row col ht i n acol)
(setq ht (/ 2.5 (getvar 'cannoscalevalue))
pct (trans pct 1 0)
 n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) 3
(* 1.5 ht) ht))
acol (vla-getinterfaceobject acobj (strcat "AutoCAD.AcCmColor." (substr
(vla-get-version acobj) 1 2)))
)
(vlax-put tab 'direction n)

(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)

(vla-put-HorzCellMargin tab (* 0.14 ht))

(vla-put-VertCellMargin tab (* 0.14 ht))

(setq lst (cons '(nil "Width" "Length" "Pcs.") lst))

(setq i 0)
(foreach col (apply 'mapcar (cons 'list (mapcar 'cdr lst)))
(vla-SetColumnWidth tab i
(apply
'max
(mapcar
'(lambda (x)
((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
(textbox (list (cons 1 (vl-princ-to-string x)) (cons 7 (getvar
'textstyle)) (cons 40 ht)))
)
)
col
)
)
)
(setq i (1+ i))
)

(setq lst (cons '(nil "RECTANGLES") lst))

(setq row 0)
(foreach r lst
(setq col 0)
(vla-SetRowHeight tab row (* 1.5 ht))
(foreach c (cdr r)
(vla-SetText tab row col (vl-princ-to-string c))
(if
(car r)
(progn
(if (/= (vla-get-colorindex acol) (car r)) (vla-put-colorindex acol (car
r)))
(vla-SetCellContentColor tab row col acol)
)
)
(setq col (1+ col))
 )
(setq row (1+ row))
)
)

(princ "\nType RECDIMS to start the command")