(defun c:OBJTREE ( / mp-doc mp-get mp-get-obj-name mp-get-object-tree mp-get-owner mp-main mp-select-props-to-string mp-select-props-to-string-aux )
(vl-load-com)
(defun mp-doc ( )
(eval
(list
'defun 'mp-doc nil
(vla-get-activedocument (vlax-get-acad-object))
)
)
(mp-doc)
)
(defun mp-get-owner ( object )
(eval
(list 'defun 'mp-get-owner '( object / owner )
(list 'vl-catch-all-apply
(list 'function
(list 'lambda nil
(list 'setq 'owner
(list
'vla-objectidtoobject
(vla-get-activedocument (vlax-get-acad-object))
(list 'vla-get-ownerid 'object)
)
)
)
)
)
'owner
)
)
(mp-get-owner object )
)
(defun mp-get-object-tree ( object )
( (lambda ( tree / owner )
(while (setq owner (mp-get-owner (car tree)))
(setq tree (cons owner tree))
)
tree
)
(list object)
)
)
(defun mp-get ( x prop / value )
(vl-catch-all-apply 'eval '((setq value (vlax-get-property x prop))))
(cond
( (null value) nil)
( (eq 'variant (type value)) (vlax-get x prop))
( (/= "OBJECTNAME" (vl-symbol-name prop)) value)
( (/= "AcDbBlockReference" value) (substr value 5))
( (eq :vlax-true
(vla-get-isxref
(vla-item (vla-get-blocks (mp-doc)) (vla-get-name x))
)
)
"ExternalReference"
)
( (substr value 5) )
)
)
(defun mp-get-obj-name ( x / name )
(if (setq name (mp-get x 'objectname))
(if (wcmatch name "AcDb*")
(substr name 5)
name
)
)
)
(defun mp-select-props-to-string-aux ( x prop pfx / label value str n )
(if (setq value (mp-get x prop))
(strcat
pfx
(if (eq 'objectname prop)
"Object"
(strcat
(substr (setq label (vl-symbol-name prop)) 1 1)
(strcase (substr label 2) t)
)
)
": "
(if (< 60 (setq n (strlen (setq str (vl-prin1-to-string value)))))
(strcat (substr str 1 26) " ... " (substr str (- n 26)))
str
)
)
""
)
)
(defun mp-select-props-to-string ( x pfx )
(strcat
(apply 'strcat
(cons "\n"
(mapcar
(function (lambda (p) (mp-select-props-to-string-aux x p pfx)))
(append
'(objectname handle name)
(if (/= (mp-get x 'name) (mp-get x 'effectivename))
'(effectivename)
)
(if (mp-get x 'path)
'(path)
'(isdynamicblock islayout isxref hasattributes)
)
'( count
units
layer
insertionpoint
startpoint
endpoint
coordinates
elevation
xscalefactor
yscalefactor
zscalefactor
rotation
color
linetype
stylename
height
tagstring
textstring
)
)
)
)
)
)
)
(defun mp-main ( / pfx tab lst foo )
(cond
( (null
(setq
pfx "\n "
tab " "
lst (nentsel "\nSelect entity: ")
)
)
)
( (null
(defun foo ( x ) ;; uses lexical globals pdx & tab
(princ
(strcat
"\n\nDocument: \""
(vla-get-fullname (mp-doc))
"\""
)
)
(defun foo ( x )
(princ (mp-select-props-to-string x pfx))
(setq pfx (strcat pfx tab))
)
)
)
)
( (eq 2 (length lst))
(foreach x (cons 42 (mp-get-object-tree (vlax-ename->vla-object (car lst))))
(foo x)
)
)
( (foreach x
(cons 42
(append
(mp-get-object-tree
(mp-get-owner
(car
(setq lst
(mapcar 'vlax-ename->vla-object
(append
(reverse (last lst))
(list (car lst))
)
)
)
)
)
)
lst
)
)
(foo x)
)
)
)
(princ)
)
;; Sample output:
;;
;; Document: "D:\Clients\ME\XREF_TESTS\HOST.dwg"
;;
;; Object: "BlockTable"
;; Handle: "1"
;; Count: 13
;;
;; Object: "BlockTableRecord"
;; Handle: "70"
;; Name: "*Model_Space"
;; Isdynamicblock: :vlax-false
;; Islayout: :vlax-true
;; Isxref: :vlax-false
;; Count: 53
;; Units: 0
;;
;; Object: "ExternalReference"
;; Handle: "3F0"
;; Name: "DWG-0000"
;; Path: ".\\DWG-0000.dwg"
;; Layer: "0"
;; Insertionpoint: (0.0 0.0 0.0)
;; Xscalefactor: 1.0
;; Yscalefactor: 1.0
;; Zscalefactor: 1.0
;; Rotation: 0.0
;; Color: 256
;; Linetype: "ByLayer"
;;
;; Object: "Text"
;; Handle: "5AD"
;; Layer: "0"
;; Insertionpoint: (-133.778 295.91 0.0)
;; Rotation: 0.0
;; Color: 2
;; Linetype: "ByLayer"
;; Stylename: "DWG-0000|Standard"
;; Height: 1.0
;; Textstring: "DWG-0000"
(mp-main)
)
Object Properties
3 - [ LWPOLYLINE ]
Elevation: 0.0
Length: 1.0
Layer: 0
Color: 7
Linetype: Continuous
Plottable: YES
2 - [ INSERT - Nautical Golf Course Site 2d|CROSS ]
Objects Within Block: 4
Layer: Nautical Golf Course Site 2d|SHEET_GRID
Color: 8
Linetype: Continuous
Plottable: YES
1 - [ XREF - Nautical Golf Course Site 2d ]
Objects Within Block: 15896
Layer: B-Nautical|xref
Color: 7
Linetype: Continuous
Plottable: YES
0 - [ XREF - B-Nautical ]
Objects Within Block: 2
Layer: xref
Color: 2
Linetype: Continuous
Plottable: YES
I think the way you chose to display it inside out vertically without indentation rather than trying to replicate a visual hierarchy as I did is superior nice, clean, uncluttered, easy to look at. 👍Thanks MP hope you have a relaxing weekend ahead. :-)
Superb work as always MP, thanks for sharing :-)
Thanks MP hope you have a relaxing weekend ahead. :-)
Edit: Massive revamp inspired by RJP - thanks RJP!(Google translator...)
(defun C:ALE_Block_Cmd_AddObj ( / BlkEnt ObjLst SelLst SelSet Countr EntObj acdoc)
(if
(and
(setq SelLst (entsel "Select Block:"))
(not (prompt "\nSelect Objects to add\n"))
(setq SelSet (ssget "_:L"))
)
(progn
(setq
acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
BlkEnt (car SelLst)
BlkNam (cdr (assoc 2 (entget BlkEnt)))
)
(prompt (strcat "\n" BlkNam))
(and
(ssmemb BlkEnt SelSet)
(progn
(setq SelSet (ssdel BlkEnt SelSet))
(alert "The original block was also selected from the objects to be added.\nThe block selection was ignored."); > Level1
)
); crash if present BlkEnt
(repeat (setq Countr (sslength SelSet))
(setq EntObj (vlax-ename->vla-object (ssname SelSet (setq Countr (1- Countr)))))
(if
(and
(= "AcDbBlockReference" (vlax-get EntObj 'ObjectName))
(= BlkNam (vlax-get EntObj 'Name))
)
(alert "A copy of the original block was also selected from the objects to be added.\nThe block selection was ignored."); > Level1
(setq ObjLst (cons EntObj ObjLst))
)
)
(vla-CopyObjects acdoc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ObjLst)))) ObjLst))
(vla-item (vla-get-Blocks acdoc) (cdr (assoc 2 (entget BlkEnt))))
)
(foreach ObjFor ObjLst (vla-delete ObjFor))
(vla-regen acdoc acAllViewports)
)
)
(princ)
)
That's pretty sweet. Thank you for sharing this!
2 - if among the selected objects there is a block that contains the block to be modified (which is less easy to avoid)
(defun mp-block-names-hosting ( doc name / get-refs find-refs mp-main )
;; get nested block refs
(defun get-refs ( b / s n d result )
(setq s '((setq n (strcase (vla-get-name x)))))
(vlax-for x b
(and
(eq "AcDbBlockReference" (vla-get-objectname x))
(eq 'str (type (vl-catch-all-apply 'eval s)))
(or (member n result) (setq result (cons n result)))
)
)
(if (setq d (entget (vlax-vla-object->ename b)))
(foreach e (mapcar 'cdr (vl-remove-if-not '(lambda (p) (eq 332 (car p))) d))
(or
(member (setq n (strcase (cdr (assoc 2 (entget e))))) result)
(setq result (cons n result))
)
)
)
(if result (cons (strcase (vla-get-name b)) (reverse result)))
)
;; find nested block refs
(defun find-refs ( lst name / n! )
;; accesses lexical global var: result
(foreach n (setq n! (car lst) lst (cdr lst))
(cond
((and (/= n name) (null (member n result))))
((member n! result))
((setq result (cons n! result)))
)
)
)
;; wrap it up
(defun mp-main ( blocks name / x lst result )
(if (eq 'vla-object (type (vl-catch-all-apply 'vla-item (list blocks name))))
(progn
(vlax-for b blocks
(and
(eq :vlax-false (vla-get-islayout b))
(setq x (get-refs b))
(setq lst (cons x lst))
)
)
(setq lst (append (reverse lst) lst))
(while
(not
(equal
(length (cdr result))
(progn
(foreach x lst (find-refs x name))
(length (cdr result))
)
)
)
)
)
)
result
)
;; pull the trigger ...
(mp-main (vla-get-blocks doc) (strcase name))
)
(if
(and
(setq ent (car (entsel)))
(eq "INSERT" (cdr (assoc 0 (setq data (entget ent)))))
(setq block-name (cdr (assoc 2 data)))
(progn (vl-load-com) t)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq nfg (cons block-name (mp-block-names-hosting doc block-name)))
(setq nfg (substr (apply 'strcat (mapcar '(lambda (n) (strcat "," n)) nfg)) 2))
(setq filter (list '(-4 . "<or") '(0 . "~INSERT") '(-4 . "<not") (cons 2 nfg) '(-4 . "not>") '(-4 . "or>")))
(setq ss (ssget filter))
)
(progn
;; ready to roll ...
)
)
Nice work Michael! <snip> here is something (http://www.theswamp.org/index.php?topic=55422.0) ...
(defun chknestblk ( blkdef name )
(vlax-for o blkdef
(cond
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false) (= (vla-get-name o) name))
t
)
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false))
(chknestblk o name)
)
)
)
)
But, isn't this enough...Many thanks to MP..., from a link indicated by Grrr1337 I found this Lee Mac function:Code: [Select](defun chknestblk ( blkdef name )
(vlax-for o blkdef
(cond
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false) (= (vla-get-name o) name))
t
)
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false))
(chknestblk o name)
)
)
)
)
(defun blockcomponents ( blk / ent enx lst )
(if (setq ent (tblobjname "block" blk))
(while (setq ent (entnext ent))
(if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
(setq lst (vl-list* (blockcomponents (cdr (assoc 2 enx))) ent lst))
(setq lst (cons ent lst))
)
)
)
(reverse lst)
)
Here is my solution, thanks ribarm I have not tested your function but I think it is a vla version of the same thinks, now I will try your solution:(defun C:ALE_Block_Cmd_AddObj ( / BlkEnt ObjLst SelLst SelSet Countr EntObj TmpNam acdoc)
(if
(and
(setq SelLst (entsel "Select Block:"))
(not (prompt "\nSelect Objects to add\n"))
(setq SelSet (ssget "_:L"))
)
(progn
(setq
acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
BlkEnt (car SelLst)
BlkNam (cdr (assoc 2 (entget BlkEnt)))
)
(prompt (strcat "\n" BlkNam))
(and
(ssmemb BlkEnt SelSet)
(progn
(setq SelSet (ssdel BlkEnt SelSet))
(alert "The original block was also selected from the objects to be added.\nThe block selection was ignored."); > Level1
)
); crash if present BlkEnt
(repeat (setq Countr (sslength SelSet))
(setq EntObj (vlax-ename->vla-object (ssname SelSet (setq Countr (1- Countr)))))
(if (= "AcDbBlockReference" (vlax-get EntObj 'ObjectName))
(if (= BlkNam (setq TmpNam (vlax-get EntObj 'Name)))
(alert "A copy of the original block was also selected from the objects to be added.\nThe block selection was ignored."); > Level1
(if (member BlkNam (NestedBlocks TmpNam nil))
(alert "A copy of the original block is inside a block selected to be added.\nThe block selection was ignored."); > nested
(setq ObjLst (cons EntObj ObjLst))
)
)
(setq ObjLst (cons EntObj ObjLst))
)
)
(vla-CopyObjects acdoc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ObjLst)))) ObjLst))
(vla-item (vla-get-Blocks acdoc) (cdr (assoc 2 (entget BlkEnt))))
)
(foreach ObjFor ObjLst (vla-delete ObjFor))
(vla-regen acdoc acAllViewports)
)
)
(princ)
)
(defun NestedBlocks (BlkNam TmpLst / EntNam EntDat TmpNam)
(if (setq EntNam (tblobjname "BLOCK" BlkNam))
(while (setq EntNam (entnext EntNam))
(and
(= "INSERT" (DXF 0 (setq EntDat (entget EntNam))))
(not (member (setq TmpNam (DXF 2 EntDat)) TmpLst))
(setq TmpLst (NestedBlocks TmpNam (cons TmpNam TmpLst)))
)
)
)
TmpLst
)
(defun Dxf (DxfCod EntDat) (cdr (assoc DxfCod EntDat)))
Don't have time to test but the anted up code by others does not appear to find all references to a block name, regardless the depth, regardless in blocks or xrefs. That's what function mp-block-names-hosting aims to do.Thanks Michael for your time:
(ALE_Block_NestedList "a1" nil) => ("b2" "c1" "b1") - a1 = 3 blocks inside
(ALE_Block_NestedList "b1" nil) => ("c1") - b1 = 1 blocks inside
(ALE_Block_NestedList "b2" nil) => nil - b2 = 0 blocks inside
(ALE_Block_NestedList "c1" nil) => nil - c1 = 0 blocks inside
;--------------------------------------------------------------------------
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(mp-block-names-hosting doc "a1") => nil > 1° problem
;--------------------------------------------------------------------------
(setq filter (list '(-4 . "<or") '(0 . "~INSERT") '(-4 . "<not") (cons 2 nfg) '(-4 . "not>") '(-4 . "or>")))
> 2° problem I think that the filter with ssget do not "filter" nested blocks
But, isn't this enough...Marco, sorry I am not able to use your function:Code: [Select](defun chknestblk ( blkdef name )
(vlax-for o blkdef
(cond
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false) (= (vla-get-name o) name))
t
)
( (and (= (vla-get-objectname o) "AcDbBlockTableRecord") (= (vla-get-islayout o) :vlax-false) (= (vla-get-isxref o) :vlax-false))
(chknestblk o name)
)
)
)
)
(defun ALE_Utl_GetItem (VlaCol KeyNam / VlaObj)
(vl-catch-all-apply
'(lambda ( )
(setq VlaObj (vla-item VlaCol KeyNam))
)
)
VlaObj
)
Comando: (setq blkdef (ALE_Utl_GetItem (vla-get-blocks (vla-get-ActiveDocument (vlax-get-Acad-Object))) "A1"))
#<VLA-OBJECT IAcadBlock 0000000032f59448>
Comando: (chknestblk blkdef "c1")
nil
(defun chknestblk ( blkdef name / chk blks r )
(defun chk ( blkdef name )
(vlax-for o blkdef
(cond
( (and (= (vla-get-objectname o) "AcDbBlockReference") (= (vla-get-name o) name))
(setq r t)
)
( (= (vla-get-objectname o) "AcDbBlockReference")
(chk (vla-item blks (vla-get-name o)) name)
)
)
)
)
(setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
(chk blkdef name)
r
)
Actually I oversimplified...Grazie. :)
It should just be like this : ...
(vlax-for b (vla-get-blocks (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(if (eq :vlax-false (vla-get-islayout b))
(princ
(strcat
"\n" (setq n (vla-get-name b)) ": "
(vl-princ-to-string (mp-block-names-hosting doc n))
)
)
)
(princ)
)
B1: (A1) | "B1" is referenced by "A1", or "A1" has 1 or more instances of "B1". |
B2: (A1) | "B2" is referenced by "A1". |
A1: nil | "A1" is not referenced by any non-layout blocks. |
C1: (A1 B1) | "C1" is referenced by "A1" & "B1". |
(defun mp-block-names-hosting ( doc name / get-refs find-refs mp-main )
;; get nested block refs
(defun get-refs ( b / s n d result )
(setq s '((setq n (strcase (vla-get-name x)))))
(vlax-for x b
(and
(eq "AcDbBlockReference" (vla-get-objectname x))
(eq 'str (type (vl-catch-all-apply 'eval s)))
(or (member n result) (setq result (cons n result)))
)
)
(if (setq d (entget (vlax-vla-object->ename b)))
(foreach e (mapcar 'cdr (vl-remove-if-not '(lambda (p) (eq 332 (car p))) d))
(or
(member (setq n (strcase (cdr (assoc 2 (entget e))))) result)
(setq result (cons n result))
)
)
)
(if result (cons (strcase (vla-get-name b)) (reverse result)))
)
;; find nested block refs
(defun find-refs ( lst name / n! )
;; accesses lexical global var: result
(foreach n (setq n! (car lst) lst (cdr lst))
(cond
((and (/= n name) (null (member n result))))
((member n! result))
((setq result (cons n! result)))
)
)
)
;; wrap it up
(defun mp-main ( blocks name / x lst result )
(if (eq 'vla-object (type (vl-catch-all-apply 'vla-item (list blocks name))))
(progn
(vlax-for b blocks
(and
(eq :vlax-false (vla-get-islayout b))
(setq x (get-refs b))
(setq lst (cons x lst))
)
)
(setq lst (append (reverse lst) lst))
(while
(not
(equal
(length (cdr result))
(progn
(foreach x lst (find-refs x name))
(length (cdr result))
)
)
)
)
)
)
result
)
;; pull the trigger ...
(mp-main (vla-get-blocks doc) (strcase name))
)
(if
(and
;; let's assume insert "B1" selected:
(setq ent (car (entsel "Select block insert to update: ")))
(eq "INSERT" (cdr (assoc 0 (setq data (entget ent)))))
;; block-name = "B1"
(setq block-name (cdr (assoc 2 data)))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
;; nfg = ("B1" "A1"), the original block selected and "A1", since it references "B1"
(setq nfg (cons block-name (mp-block-names-hosting doc block-name)))
(setq nfg (substr (apply 'strcat (mapcar '(lambda (n) (strcat "," n)) nfg)) 2))
;; filter = ((-4 . "<or") (0 . "~INSERT") (-4 . "<not") (2 . "B1,A1") (-4 . "not>") (-4 . "or>"))
(setq filter (list '(-4 . "<or") '(0 . "~INSERT") '(-4 . "<not") (cons 2 nfg) '(-4 . "not>") '(-4 . "or>")))
(setq ss (ssget filter))
)
(progn
(princ
(strcat
"\nFilter: " (vl-prin1-to-string filter)
"\nAllowed: " (itoa (sslength ss)) " objects"
" that can be added to block def \"" block-name "\"."
)
)
;; ready to roll ...
(princ)
)
(princ)
)
@MP: firstly, congrats on impressive work and a thorough explanation :-)
I may have overlooked something, but assume that block "A" is nested within block "B", and block "B" is nested within block "C", and that the supplied name argument is "A"; for mp-main to return ("B" "C") relies on the definition of "B" being encountered in the block table before "C" - is this a safe assumption to make?
(vlax-for b (vla-get-blocks (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(if (eq :vlax-false (vla-get-islayout b))
(princ
(strcat
"\n" (setq n (vla-get-name b)) ": "
(vl-princ-to-string (mp-block-names-hosting doc n))
)
)
)
(princ)
)