Author Topic: You always look at me like I'm an object (today's freebie) ...  (Read 5509 times)

0 Members and 1 Guest are viewing this topic.

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
You always look at me like I'm an object (today's freebie) ...
« on: October 16, 2020, 04:37:18 PM »
Potentially useful to you if you deal with a lot of nested objects -- e.g. XREFs or deeply nested block defs -- and wish to view the owner hierarchy.

Edit: Massive revamp inspired by RJP - thanks RJP!

Code: [Select]
(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)

)

ObjTree {enter} Select entity: {pick entity}

Output:

Document: "D:\Clients\MP\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: "3dPolyline"
            Handle: "5C2"
            Layer: "0"
            Coordinates: (-117.492 293.127 0.0 -113 ... 1 0.0 -109.269 297.204 0.0)
            Color: 256
            Linetype: "ByLayer"

                Object: "3dPolylineVertex"
                Handle: "5C6"
                Layer: "0"
                Color: 256
                Linetype: "ByLayer"


Cheers.
« Last Edit: October 22, 2020, 07:12:52 AM by MP »
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

ronjonp

  • Needs a day job
  • Posts: 7526
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #1 on: October 16, 2020, 04:48:19 PM »
Awesome as always thanks for sharing  8-)

I have something similar to get properties of nested objects:
Quote
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

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #2 on: October 16, 2020, 05:02:20 PM »
Thanks + coolness as always = another swamp win!

An aside, I wrote the preceding when I was figuring out how to abuse the z-order of xrefs in a in highly nested hierarchy - insitu. Fun challenge. {blink}
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #3 on: October 16, 2020, 05:27:19 PM »
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. 👍
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

ronjonp

  • Needs a day job
  • Posts: 7526
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #4 on: October 16, 2020, 09:49:08 PM »
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.  :-)

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #5 on: October 17, 2020, 07:56:21 AM »
Superb work as always MP, thanks for sharing  :-)

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #6 on: October 17, 2020, 11:35:52 AM »
Superb work as always MP, thanks for sharing  :-)

Nice, thanks Lee! :)

Thanks MP hope you have a relaxing weekend ahead.  :-)

That would be a nice change! :-D Double that back to you. :)

Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #7 on: October 18, 2020, 04:30:16 PM »
Edit: Massive revamp inspired by RJP - thanks RJP!
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #8 on: October 19, 2020, 04:15:51 AM »
Nice work Michael !

I was always interested about 'object digging' in order to display the hierarchical structure in the form of treeview, or atleast somehow dig into it -
where the goal was to get better understanding.

Not trying to steal the thread, but here is something similar I've tried back in the days, and another one I did few years ago (not as good as your custom object browser).

Thanks for sharing!  8-)
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #9 on: October 19, 2020, 05:28:39 AM »
Edit: Massive revamp inspired by RJP - thanks RJP!
(Google translator...)
Grazie Michael to share your functions always very interesting and useful ... I take a cue from this topic to ask a question that can be solved with a similar function (maybe it already exists).

Below is a simplified version of http://www.lee-mac.com/addobjectstoblock.html (no vla-transformby by Matrix)
> found two potentially dangerous situations that cause the CAD to crash for recursive block creation:
1 - if the block to be modified is included in the selection of new objects to be added (can be solved see > Level1)
2 - if among the selected objects there is a block that contains the block to be modified (which is less easy to avoid)

The block command anticipates these situations and aborts the command with a warning message.

Problem: find if in the selection of objects to add there is a block that contains (at any level) the block to which the objects are being added.

Code: [Select]
(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)
)

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #10 on: October 19, 2020, 07:13:03 AM »
That's pretty sweet. Thank you for sharing this!
Civil3D 2020

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #11 on: October 19, 2020, 11:05:59 AM »
That's pretty sweet. Thank you for sharing this!

Thanks man. :)

2 - if among the selected objects there is a block that contains the block to be modified (which is less easy to avoid)

If I pretend to understand the following quick & dirty (i.e. not polished by any means) code snip (sorry, working, all I have time for) should prevent you from selecting any inserts representing blocks or xrefs, that host an instance of the initial block insert chosen to update (hope that made sense) regardless the nesting depth ...

Code: [Select]
(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))
)

Ok, put it to work ...
                 
Code: [Select]
(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 ...

Coolness, will check out when I have time to digest! :)
« Last Edit: October 22, 2020, 09:13:12 AM by MP »
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

JohnK

  • Administrator
  • Seagull
  • Posts: 10605
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #12 on: October 19, 2020, 12:02:30 PM »
Does this thread need to be moved to "show your stuff"?
TheSwamp.org (serving the CAD community since 2003)
Member location map - Add yourself

Donate to TheSwamp.org

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #13 on: October 19, 2020, 12:24:07 PM »
Not imo but what do I know about beer? :crazy2:
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #14 on: October 19, 2020, 01:57:46 PM »
But, isn't this enough...

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)
      )
    )
  )
)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #15 on: October 19, 2020, 03:22:18 PM »
But, isn't this enough...

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)
      )
    )
  )
)
Many thanks to MP..., from a link indicated by Grrr1337 I found this Lee Mac function:
Code: [Select]
(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:
Code: [Select]
(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)))

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #16 on: October 19, 2020, 05:24:51 PM »
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.
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #17 on: October 20, 2020, 02:58:24 AM »
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:
Code: [Select]
(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

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #18 on: October 20, 2020, 03:24:04 AM »
But, isn't this enough...

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)
      )
    )
  )
)
Marco, sorry I am not able to use your function:
Code: [Select]
(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

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #19 on: October 20, 2020, 06:46:58 AM »
Actually I oversimplified...
It should just be like this :

Code: [Select]
(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
)

HTH.
« Last Edit: October 20, 2020, 07:21:17 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube


MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #21 on: October 20, 2020, 09:12:19 PM »
Hi Marco. My approach to your challenge was to pen a function that returned all the references (direct / indirect) to a given block name, not all the block names hosted by a block name.

To illustrate, in your sample drawing block "C1" is referenced by "B1" and "B1" is referenced by "A1". Said another way, "A1" has an instance of "B1", and "B1" has an instance of "C1".

My rationale being that if one wished to update "C1" by adding selected objects, and the selection set included instances of either "A1", "B1" or "C1" it would be doomed to failure since any one one them would cause a circular reference -- directly or indirectly.

Thus if you select a block to modify, say "C1", a selection filter was created that prevents selecting any instances of "A1", "B1", "C1". Hope that makes sense.

In your sample drawing this is what each name would return using the function I penned:

Code: [Select]
(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".

In the latter case "B1" is direct, "A1" is indirect, as "B1" has 1 or more instances of "C1", "A1" has 1 or more instances of "B1".

An aside, the original flavor I posted would fail if there were no instances of the block you wished to revise, as it was leveraging the instancing that can be quickly lifted from the block def via dxf 331 pairs. It's been updated to use the slower - but more reliable - "iterate all child objects" technique.

While seemingly verbose, it performs reasonably fast and will also find references within XREFs. The latter can be tricky when they're nested via cascaded attaches as the nesting does not manifest via AcDbBlockReference instances but rather AbDbBlockTableRecord instances at the root level of each XREF, flagged by dxf 332 sentinels. I know, a lot to digest - sorry - don't know how to say it clearer or more concisely.

Anyway, using:

Code: [Select]
(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))
)


A filter can be created preventing the user from selecting any blocks that would cause a circular reference to the original block insert selected:

Code: [Select]
(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)
)

Might report:

Filter:  ((-4 . "<or") (0 . "~INSERT") (-4 . "<not") (2 . "B1,A1") (-4 . "not>") (-4 . "or>"))
Allowed: 9 objects that can be added to block def "B1".


If you selected all visible entities.

Hope it makes sense - for what it's worth - Michael.

Revised per posts 25-27.
« Last Edit: October 22, 2020, 09:14:59 AM by MP »
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #22 on: October 21, 2020, 03:05:38 AM »
Thanks again Michael for your time and patience, I believe it is a detailed explanation that will be useful to many.
Marco

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #23 on: October 21, 2020, 08:20:04 AM »
You’re most welcome my friend - hope it helps - cheers.
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #24 on: October 21, 2020, 05:05:59 PM »
@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?

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #25 on: October 21, 2020, 05:28:05 PM »
@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?

Thanks Lee + that is correct + having mused over it means that if any block is revised after subsequent blocks are established - to reference said latter blocks - the "forward" reference(s) would elude detection with the current algorithm. tldr: algorithm is flawed = will fix when I have some play time. :)

This can be easily illustrated by nested (attached) xrefs:

    DWG-0000.dwg
        DWG-0001.dwg
            DWG-0002.dwg
                DWG-0003.dwg
                    DWG-0004.dwg
                        DWG-0005.dwg

                   
Code: [Select]
(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)
)

Would report:

    DWG-0000: nil
    DWG-0001: (DWG-0000)
    DWG-0002: (DWG-0000 DWG-0001)
    DWG-0003: (DWG-0000 DWG-0001 DWG-0002)
    DWG-0004: (DWG-0000 DWG-0001 DWG-0002 DWG-0003)
    DWG-0005: (DWG-0000 DWG-0001 DWG-0002 DWG-0003 DWG-0004)


Which is correct.

If the entire XREF tree is bound the same code reports:

    DWG-0000: nil
    DWG-0001: (DWG-0000)
    DWG-0002: (DWG-0001)
    DWG-0003: (DWG-0002)
    DWG-0004: (DWG-0003)
    DWG-0005: (DWG-0004)


Which is incorrect.

Probably solve-able by doing at least one forward pass followed by a backward pass. Since the data could be collected on the initial pass the second pass processing time could be a fraction of the former. /thinking out loud.

tldr: Thanks for reviewing and revealing a flaw my friend!

:lol:

« Last Edit: October 22, 2020, 08:40:48 AM by MP »
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: You always look at me like I'm an object (today's freebie) ...
« Reply #26 on: October 21, 2020, 08:32:42 PM »
Code revised in post #22. Good until new logic errors found. :lol:
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst