Author Topic: You always look at me like I'm an object (today's freebie) ...  (Read 5507 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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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.comhttp://cadanalyst.slack.comhttp://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