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

0 Members and 1 Guest are viewing this topic.

MP

  • Seagull
  • Posts: 17714
  • 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 - Auto/Visual Lisp: [Select]
  1. (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 )
  2.  
  3.     (vl-load-com)
  4.    
  5.     (defun mp-doc ( )
  6.         (eval
  7.             (list
  8.                'defun 'mp-doc nil
  9.                 (vla-get-activedocument (vlax-get-acad-object))
  10.             )
  11.         )
  12.         (mp-doc)
  13.     )
  14.    
  15.     (defun mp-get-owner ( object )
  16.         (eval
  17.             (list 'defun 'mp-get-owner '( object / owner )
  18.                 (list 'vl-catch-all-apply
  19.                     (list 'function
  20.                         (list 'lambda nil
  21.                             (list 'setq 'owner
  22.                                 (list
  23.                                     'vla-objectidtoobject
  24.                                     (vla-get-activedocument (vlax-get-acad-object))
  25.                                     (list 'vla-get-ownerid 'object)
  26.                                 )
  27.                             )
  28.                         )
  29.                     )      
  30.                 )
  31.                'owner
  32.             )
  33.         )
  34.         (mp-get-owner object )
  35.     )
  36.  
  37.     (defun mp-get-object-tree ( object )
  38.         (   (lambda ( tree / owner )
  39.                 (while (setq owner (mp-get-owner (car tree)))
  40.                     (setq tree (cons owner tree))
  41.                 )
  42.                 tree
  43.             )
  44.             (list object)
  45.         )
  46.     )
  47.    
  48.     (defun mp-get ( x prop / value )
  49.         (vl-catch-all-apply 'eval '((setq value (vlax-get-property x prop))))
  50.         (cond
  51.             (   (null value) nil)
  52.             (   (eq 'variant (type value)) (vlax-get x prop))
  53.             (   (/= "OBJECTNAME" (vl-symbol-name prop)) value)
  54.             (   (/= "AcDbBlockReference" value) (substr value 5))
  55.             (   (eq :vlax-true
  56.                     (vla-get-isxref
  57.                         (vla-item (vla-get-blocks (mp-doc)) (vla-get-name x))
  58.                     )
  59.                 )
  60.                 "ExternalReference"
  61.             )
  62.             (   (substr value 5)   )
  63.         )
  64.     )
  65.    
  66.     (defun mp-get-obj-name ( x / name )
  67.         (if (setq name (mp-get x 'objectname))
  68.             (if (wcmatch name "AcDb*")
  69.                 (substr name 5)
  70.                 name
  71.             )    
  72.         )
  73.     )
  74.    
  75.     (defun mp-select-props-to-string-aux ( x prop pfx / label value str n )
  76.         (if (setq value (mp-get x prop))
  77.             (strcat
  78.                 pfx
  79.                 (if (eq 'objectname prop)
  80.                     "Object"
  81.                     (strcat
  82.                         (substr (setq label (vl-symbol-name prop)) 1 1)
  83.                         (strcase (substr label 2) t)
  84.                     )
  85.                 )                            
  86.                 ": "
  87.                 (if (< 60 (setq n (strlen (setq str (vl-prin1-to-string value)))))
  88.                     (strcat (substr str 1 26) " ... " (substr str (- n 26)))
  89.                     str
  90.                 )
  91.             )
  92.             ""
  93.         )    
  94.     )  
  95.    
  96.     (defun mp-select-props-to-string ( x pfx )
  97.         (strcat
  98.             (apply 'strcat
  99.                 (cons "\n"
  100.                     (mapcar
  101.                         (function (lambda (p) (mp-select-props-to-string-aux x p pfx)))
  102.                         (append
  103.                            '(objectname handle name)
  104.                             (if (/= (mp-get x 'name) (mp-get x 'effectivename))
  105.                                '(effectivename)
  106.                             )
  107.                             (if (mp-get x 'path)
  108.                                '(path)
  109.                                '(isdynamicblock islayout isxref hasattributes)    
  110.                             )
  111.                            '(   count
  112.                                 units
  113.                                 layer
  114.                                 insertionpoint
  115.                                 startpoint
  116.                                 endpoint
  117.                                 coordinates
  118.                                 elevation
  119.                                 xscalefactor
  120.                                 yscalefactor
  121.                                 zscalefactor
  122.                                 rotation
  123.                                 color
  124.                                 linetype
  125.                                 stylename
  126.                                 height
  127.                                 tagstring
  128.                                 textstring
  129.                             )
  130.                         )      
  131.                     )
  132.                 )      
  133.             )
  134.         )
  135.     )
  136.  
  137.     (defun mp-main ( / pfx tab lst foo )
  138.         (cond
  139.             (   (null
  140.                     (setq
  141.                         pfx "\n    "
  142.                         tab "    "
  143.                         lst (nentsel "\nSelect entity: ")
  144.                     )
  145.                 )
  146.             )
  147.             (   (null
  148.                     (defun foo ( x ) ;; uses lexical globals pdx & tab
  149.                         (princ
  150.                             (strcat
  151.                                 "\n\nDocument: \""
  152.                                 (vla-get-fullname (mp-doc))
  153.                                 "\""
  154.                             )
  155.                         )
  156.                         (defun foo ( x )
  157.                             (princ (mp-select-props-to-string x pfx))
  158.                             (setq pfx (strcat pfx tab))
  159.                         )
  160.                     )
  161.                 )
  162.             )
  163.             (   (eq 2 (length lst))
  164.                 (foreach x (cons 42 (mp-get-object-tree (vlax-ename->vla-object (car lst))))
  165.                     (foo x)
  166.                 )
  167.             )
  168.             (   (foreach x
  169.                     (cons 42
  170.                         (append
  171.                             (mp-get-object-tree
  172.                                 (mp-get-owner
  173.                                     (car
  174.                                         (setq lst
  175.                                             (mapcar 'vlax-ename->vla-object
  176.                                                 (append
  177.                                                     (reverse (last lst))
  178.                                                     (list (car lst))
  179.                                                 )
  180.                                             )
  181.                                         )
  182.                                     )
  183.                                 )
  184.                             )
  185.                             lst
  186.                         )
  187.                     )    
  188.                     (foo x)
  189.                 )
  190.             )
  191.         )
  192.         (princ)
  193.     )
  194.    
  195.     ;;  Sample output:
  196.     ;;
  197.     ;;  Document: "D:\Clients\ME\XREF_TESTS\HOST.dwg"
  198.     ;;
  199.     ;;      Object: "BlockTable"
  200.     ;;      Handle: "1"
  201.     ;;      Count: 13
  202.     ;;
  203.     ;;          Object: "BlockTableRecord"
  204.     ;;          Handle: "70"
  205.     ;;          Name: "*Model_Space"
  206.     ;;          Isdynamicblock: :vlax-false
  207.     ;;          Islayout: :vlax-true
  208.     ;;          Isxref: :vlax-false
  209.     ;;          Count: 53
  210.     ;;          Units: 0
  211.     ;;
  212.     ;;              Object: "ExternalReference"
  213.     ;;              Handle: "3F0"
  214.     ;;              Name: "DWG-0000"
  215.     ;;              Path: ".\\DWG-0000.dwg"
  216.     ;;              Layer: "0"
  217.     ;;              Insertionpoint: (0.0 0.0 0.0)
  218.     ;;              Xscalefactor: 1.0
  219.     ;;              Yscalefactor: 1.0
  220.     ;;              Zscalefactor: 1.0
  221.     ;;              Rotation: 0.0
  222.     ;;              Color: 256
  223.     ;;              Linetype: "ByLayer"
  224.     ;;
  225.     ;;                  Object: "Text"
  226.     ;;                  Handle: "5AD"
  227.     ;;                  Layer: "0"
  228.     ;;                  Insertionpoint: (-133.778 295.91 0.0)
  229.     ;;                  Rotation: 0.0
  230.     ;;                  Color: 2
  231.     ;;                  Linetype: "ByLayer"
  232.     ;;                  Stylename: "DWG-0000|Standard"
  233.     ;;                  Height: 1.0
  234.     ;;                  Textstring: "DWG-0000"                  
  235.  
  236.     (mp-main)
  237.  
  238. )

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 18, 2020, 10:59:14 PM 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: 7180
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 10 x64 - AutoCAD /C3D 2020

Custom Build PC

MP

  • Seagull
  • Posts: 17714
  • 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: 17714
  • 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: 7180
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 10 x64 - AutoCAD /C3D 2020

Custom Build PC

Lee Mac

  • Seagull
  • Posts: 12394
  • 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: 17714
  • 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: 17714
  • 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: 736
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)
  )
)

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1086
  • 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

  • Water Moccasin
  • Posts: 2443
  • 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!
Autodesk Infrastructure Design Suite 2019

MP

  • Seagull
  • Posts: 17714
  • 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 / mp-fni mp-fnd mp-main )
    ;;  finds block name references, no matter the nesting, withion blocks & xrefs
    (defun mp-fni ( b name / n )
        ;;  accesses lexical global var: result
        (vlax-for x b
            (cond
                ((not (eq "AcDbBlockReference" (vla-get-objectname x))))
                ((vl-catch-all-error-p (vl-catch-all-apply 'eval '((setq n (strcase (vla-get-name x)))))))
                ((and (/= n name) (null (member n result))))
                ((member (setq n (strcase (vla-get-name b))) result))
                ((setq result (cons n result)))
            )
        )
    )
    (defun mp-fnd ( b name / l k v n )
        ;;  accesses lexical global var: result
        (if (setq l (reverse (cdr (member '(102 . "{BLKREFS") (entget (vlax-vla-object->ename b))))))
            (foreach p (member (assoc 332 l) l)
                (and
                    (eq 332 (car (mapcar 'set '(k v) (list (car p) (cdr p)))))
                    (setq n (strcase (cdr (assoc 2 (entget v)))))
                    (or (eq n name) (member n result))
                    (null (member (setq n (strcase (vla-get-name b))) result))
                    (setq result (cons n result))
                )
            )
        )
    )
    (defun mp-main ( blocks name / n lst result )
        ;;  establishes lexical global var: result
        (if (eq 'vla-object (type (vl-catch-all-apply 'vla-item (list blocks name))))
            (vlax-for b blocks
                (cond
                    ((eq :vlax-true (vla-get-islayout b)))
                    ((vl-catch-all-error-p (vl-catch-all-apply 'eval '((setq n (strcase (vla-get-name b)))))))
                    ((eq name (strcase n)))
                    ((progn (mp-fni b name) (if (eq :vlax-true (vla-get-isxref b)) (setq lst (cons b lst)))))
                )
            )
        )
        (foreach b lst (mp-fnd b name))
        result
    )
    (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: Today at 07:27:32 PM 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

John Kaul (Se7en)

  • Administrator
  • Needs a day job
  • Posts: 9502
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)

Donate to TheSwamp.org

MP

  • Seagull
  • Posts: 17714
  • 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

  • Water Moccasin
  • Posts: 2401
  • 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