Contador de bloques

;;;---------------------------------------------------------------------------------------------------------------------
;;;CuentaBloques
;;;Mcommands 2009, Guadalajara, Jalisco México
;;;Autor Marco Antonio Jacinto Pérez
;;;---------------------------------------------------------------------------------------------------------------------
;;;Esta rutina obtendra los bloques por medio de una seleccion en pantalla,
;;;o automaticamente del Espacio Modelo o Papel para despues contarlos
;;;y crear una tabla con las cantidades y una insercion del mismo.
;;;---------------------------------------------------------------------------------------------------------------------

(vl-load-com)

(defun AddTextStyle
(TxtStyleName Font doc / *Textstyles* NewStyle)
(and
(setq *Textstyles*
(vla-get-TextStyles
doc
)
)
(not (collection-item-p *Textstyles* TxtStyleName))
(setq NewStyle (vla-add *Textstyles* TxtStyleName))
(vla-setFont NewStyle Font :vlax-false :vlax-false 0 0)
)
NewStyle
)


;;;----------------------------------------------;;;
;;;This function will pass a function to each ;;;
;;;element of a selection set ;;;
;;;----------------------------------------------;;;

(defun for-sset (sset f / n)
(if (= 'PICKSET (type sset)) ; _this will chek if the arguments is
; a
; selection
; set
(repeat (progn (setq n -1) (sslength sset))
(f (ssname sset (setq n (1+ n))))
)
)
)
;;;----------------------------------------------;;;

(defun collection-item-p (collection Item)
(cond ((vl-catch-all-error-p
(vl-catch-all-apply 'vla-item (list Collection Item))
)
nil
)
(t (vla-item Collection Item))
)
)

(defun list->variantArray (ptsList / arraySpace sArray)
; _ allocate space for an
; array of 2d points
; stored as
; doubles
(setq arraySpace
(vlax-make-safearray
vlax-vbdouble ;_ element type
(cons 0 (- (length ptsList) 1)) ;_ array dimension
)
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
; _ return array
; variant
(vlax-make-variant sArray)
)


(defun NameUnnamedUcs
(*adoc* UcsName / *UCS* Origin XAxisPoint YAxisPoint)
(if (= (getvar "WORLDUCS") 0) ;If UCS Difers from world then
(progn
(Setq *UCS* (vla-get-UserCoordinateSystems *adoc*)
Origin (getvar "UCSORG")
XAxisPoint (mapcar '(lambda (pt1 pt2) (+ pt1 pt2))
Origin
(getvar "UCSXDIR")
)
YAxisPoint (mapcar '(lambda (pt1 pt2) (+ pt1 pt2))
Origin
(getvar "UCSyDIR")
)
)
(vla-add *Ucs*
(list->variantArray Origin)
(list->variantArray XAxisPoint)
(list->variantArray YAxisPoint)
UcsName
)
)
)
)

(defun GetBlocks (space /)
(cond ((= (Type Space) 'STR)
(vlax-for obj (vla-get-block
(vla-item *layouts*
space
)
)
(bkobj obj)
)
)
((= (Type Space) 'PICKSET) ;(setq Space ss)
(for-sset Space
(lambda (ename / obj)
(setq obj (vlax-ename->vla-object ename))
(bkobj obj)
)
)
)
)
BkCountLst
)

(defun bkObj (obj / BkName)
(cond ((/= (vla-get-ObjectName obj) "AcDbBlockReference"))
((and
(setq BkName (vla-get-effectiveName obj))
(assoc BkName BkCountLst)
)
(setq BkCountLst
(subst (cons BkName (1+ (cdr (assoc BkName BkCountLst))))
(assoc BkName BkCountLst)
BkCountLst
)
)
)
(T
(setq BkCountLst
(cons (cons BkName 1) BkCountLst)
)
)
)
)


(Defun c:CuentaBloques (/ *acad* *adoc* *Layouts*
BkCountLst SpaceBkCt ptt *tabla*
Table1 *BLOCKS* CTROW ROW
*TABLESTYLE* CTC COL_CT
LayName NwUcs ss
)

(setq *acad* (vlax-get-acad-object)
*adoc* (vla-get-activedocument *acad*)
*Layouts* (vla-get-Layouts *adoc*)
*blocks* (vla-get-Blocks *adoc*)
)
(vla-startundomark *adoc*)
(or (setq NwUcs (collection-item-p
(vla-get-UserCoordinateSystems *adoc*)
"BTUcs"
)
)
)

(initget "Seleccion EspacioModelo espacioPapel Ambos")
(setq SpaceBkCt
(GetKword
"\n Contar bloques en [/EspacioModelo/espacioPapel/Ambos]"
)
)
(cond
((or (= SpaceBkCt "Seleccion") (= SpaceBkCt nil))
(setq SpaceBkCt "Seleccion")
(while (null ss)
(setq ss (ssget '((0 . "INSERT"))))
)
(princ "\n Obteniendo los bloques en la selección...")
(GetBlocks ss)
)
((= SpaceBkCt "EspacioModelo")
(setq SpaceBkCt "EspacioModelo")
(princ "\n Obteniendo bloques en el Espacio modelo...")
(GetBlocks "Model")
)
((= SpaceBkCt "espacioPapel")
(initget "Todos Escribir Actual")
(setq GetPs
(GetKword
"\n Contar bloques en el layout [/Escribir nombre/Todos]: "
)
)
(cond
((or (= GetPs nil) (= GetPs "Actual"))
(princ "\n Obteniendo los bloques en el layout actual...")
(GetBlocks (getvar "ctab"))
(setq SpaceBkCt "Layout actual")
)
((= GetPs "Todos")
(princ "\n Obteniendo bloques en todos los layouts...")
(setq Layouts (layoutlist))
(foreach lay layouts
(GetBlocks lay)
)
(setq SpaceBkCt "todos los Layouts")
)
(t
(while (not (member LayName (mapcar 'strcase (layoutlist))))
(setq LayName (strcase (getString "\n Type layout name: " T)))
)
(mapcar 'princ
(list "\n Obteniendo bloques en el layout " LayName "...")
)
(GetBlocks LayName)
(setq SpaceBkCt (strcat "Layout " LayName))
)
)
)
(t
(princ "\n Obteniendo bloques en espacio Modelo y en espacio Papel...")
(setq Layouts (cons "Model" (layoutlist)))
(foreach lay layouts
(GetBlocks lay)
)
)
)
(if BkCountLst
(progn
(setq BkCountLst
(vl-sort BkCountLst
(function (lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
;(mapcar 'print BkCountLst)
(princ "finalizado")
(cond ((collection-item-p
(vla-get-dictionaries *adoc*)
"TablaBlocks"
)
)
(T
(AddTextStyle "Anot_Arial" "ARIAL" *adoc*)
(setq *tableStyle* (vla-item (vla-get-dictionaries *adoc*)
"acad_tablestyle"
)
*tabla* (vla-addObject
*tableStyle*
"TablaBlocks"
"AcDbTableStyle"
)
)
(vla-SetTextHeight *tabla* acTitleRow 0.175)
(vla-SetTextHeight *tabla* acHeaderRow 0.135)
(vla-SetTextHeight *tabla* acDataRow 0.125)
(vla-SetTextStyle *tabla* acHeaderRow "Anot_Arial")
(vla-SetTextStyle *tabla* acTitleRow "Anot_Arial")
(vla-SetTextStyle *tabla* acDataRow "Anot_Arial")
(vla-put-Vertcellmargin *tabla* 0.075)
(vla-put-Horzcellmargin *tabla* 0.175)
)
)
(or ptt
(setq
ptt
;(trans
(getPoint
"\n Especifica el punto de inserción para la tabla:"
)
;;; 1
;;; 0
;;; )
)
)
(progn
(princ "\n Creando tabla, espera... ")
(setq Ptt (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
'(0 . 2)
)
ptt
)
)
;;;object.AddTable(InsertionPoint, NumRows, NumColumns, RowHeight, ColWidth)
Table1 (vla-addTable
(vla-get-ModelSpace
*adoc*
)
ptt
2
3
0.20
2.00
)
ctc 0
)
(vla-put-StyleName Table1 "TablaBlocks")
(vla-setText
Table1
0
0
(strcase (strcat "Bloques en "
(if (= SpaceBkCt "Ambos")
"dibujo"
SpaceBkCt
)
)
)
)
(vla-setText Table1 1 0 "BLOQUE")
(vla-setText Table1 1 1 "NOMBRE")
(vla-setText Table1 1 2 "CANTIDAD")
(vla-setcolumnwidth Table1 0 1.20)
(vla-setcolumnwidth Table1 1 3.00)
(vla-setcolumnwidth Table1 2 1.45)
(vla-setRowHeight Table1 0 0.50)
(vla-setrowHeight Table1 1 0.35)
(if (setq NwUcs (NameUnnamedUcs *adoc* "BTUcs"))
(progn
(setq TransMatrix (vla-getUcsMatrix NwUcs))
(vla-TransformBy Table1 TransMatrix)
)
)
)

(setq row 2)
(foreach BksLst BkCountLst ;(setq BksLst (car BkCountLst))
(vla-insertrows Table1 row 0.35 1)
(setq Col_ct 0)
(vla-SetCellType Table1 row Col_ct acBlockCell)
(vla-SetBlockTableRecordId
Table1
row
Col_ct
(vla-get-ObjectID (vla-item *blocks* (car BksLst)))
:vlax-true
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (strcase (car BksLst)) Vlax-VbString)
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (cdr BksLst) Vlax-VbString)
)
(setq row (1+ row)
)
)
(setq ctrow 2)
(repeat (- (vla-get-rows table1) 2)
(vla-setcellalignment Table1 ctrow 1 acmiddleleft)
(setq ctrow (1+ ctrow))
)
(princ "finalizado")
)
(mapcar 'princ
(list "\n No hay referencias del bloque en "
SpaceBkCt
"."
)
)
)
(vla-endundomark *adoc*)
(princ)
)