Lisp to get attribute from selection for block name

[dvanerem]

I am trying to make a routine that would allow me to make a block out of a selection and name the block the attribute value from the selection. The selection will only have one attribute in it. It would also be nice if it could automatically select the very bottom left corner of the selection for the base point but I am not sure how to get to that point. I have tried to put something together but it does not appear to work, any help would be awesome. 

(defun c:QB (/ selectionset insertionpoint number Blockname)
(defun _getatt (block tag / att result)
(foreach att (vlax-invoke block 'getattributes)
(if (eq (strcase tag) (strcase (vla-get-tagstring att)))
(progn (setq result (vla-get-textstring att)))
)
)
result
)
(if (and (setq selectionset (ssget "_:L"))
(setq insertionpoint (getpoint "\n Specify insertion point :"))
)
(progn
(setq number 1
Blockname (_getatt)
)
(while (tblsearch "BLOCK" Blockname)
(setq Blockname
(strcat "MyBlock" (itoa (setq number (1+ number))))
)
)
(command "_.-Block" Blockname insertionpoint selectionset "")
(command "_.-insert" Blockname insertionpoint "" "" "")
)
(princ)
)
(princ)
)

[mid-awe]

It looks like the part of your code:

Blockname (_getatt)

needs to have arguments. _getatt (block tag / att result)
block & tag, expect a block name and attribute tag.

The base point can be derived from the bounding box of the selection set.

[dvanerem]

It give me this when I try to do that:

Error: no function definition: BLOCKAutoCAD variable setting rejected: "cmdecho" nil
Command:

I have also attached a file that shows an example of something i would select. 

[mid-awe]

I just tried to test your code and noticed that it is far off from the process you described. (I am on my way home and will try look at it again later tonight).

What you ask doesn't seem unreasonable and I am in the mood for some coding. check back later or tomorrow and I hope to have it for you unless someone else does it before me.

[Lee_Mac]

Try the following code:

(defun c:qb ( / blk bln bpt doc idx llp lst obj sel tmp )
    (if (setq sel (ssget "_:L" (list (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")))))
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                      lst (cons obj lst)
                )
                (if (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
                    )
                    (setq bpt (cond ((mapcar 'min bpt (vlax-safearray->list llp))) ((vlax-safearray->list llp))))
                )
                (if (and (null bln)
                         (= "AcDbBlockReference" (vla-get-objectname obj))
                         (= :vlax-true (vla-get-hasattributes obj))
                         (snvalid (setq tmp (vla-get-textstring (car (vlax-invoke obj 'getattributes)))))
                    )
                    (setq bln tmp)
                )
            )
            (if bln
                (if (tblsearch "block" bln)
                    (progn
                        (setq tmp 1)
                        (while (tblsearch "block" (strcat bln (itoa (setq tmp (1+ tmp))))))
                        (setq bln (strcat bln (itoa tmp)))
                    )
                )
                (setq bln "*U")
            )
            (setq doc (vla-get-activedocument (vlax-get-acad-object))
                  blk (vlax-invoke (vla-get-blocks doc) 'add bpt bln)
            )
            (vlax-invoke doc 'copyobjects lst blk)
            (vlax-invoke
                (vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                'insertblock bpt (vla-get-name blk) 1.0 1.0 1.0 0.0
            )
            (foreach obj lst (vla-delete obj))
            (princ (strcat "\nCreated block: \"" (vla-get-name blk) "\"."))
        )
    )
    (princ)
)
(vl-load-com) (princ)

[dvanerem]

This works really well. However one thing that is a bit of a problem is that I have images in most of these when I am making the block. I always send the image to the back before I run the block command. when i ran this routine it appears that the image is now on top. Do you have a way of making sure an image goes to the bottom while it is blocking this, or keeping the original draw order? 

[mid-awe]

Your code works beautifully! 🙂

[dvanerem]

Also, if possible can it put a letter after the block number if it is the same block name that already exists instead of putting a 1 after it? This code is well over my understanding of basic lisp that I have done. 

[mid-awe]

Would you filter the underlay and set the draworder?

I'm trying to work it out.

[dvanerem]

I am not sure what filtering the underlay is. However what I do currently is select the image, right click, draw order, send to back. I usually use quick select to select all of the images in my file and do it all at once. So the draw order is correct before I would run this command. But this must change it somehow. 

[mid-awe]

This is what I came up with. Lee is sure to do it with finess. I force it most of the time 🙂

(PROGN
 (SETQ PDFUNDLAY (SSGET "_X" '((0 . "PDFUNDERLAY") (410 . "Model"))))
 (VL-CMDF "_.draworder" PDFUNDLAY "" "back")
)

 I am not sure how to add it into lee's code but it should work. [ tested lightly ]

[dvanerem]

I tried to place this in a couple of locations in the code, but it just gives me an application error and does the same thing, it send the image to the front. Not sure where to put this in the code either. 

[mid-awe]

Here is Lee's code with my mod.

(defun c:qb ( / blk bln bpt doc idx llp lst obj sel tmp PDFUNDLAY)
    (if (setq sel (ssget "_:L" (list (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")))))
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                      lst (cons obj lst)
                )
                (if (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
                    )
                    (setq bpt (cond ((mapcar 'min bpt (vlax-safearray->list llp))) ((vlax-safearray->list llp))))
                )
                (if (and (null bln)
                         (= "AcDbBlockReference" (vla-get-objectname obj))
                         (= :vlax-true (vla-get-hasattributes obj))
                         (snvalid (setq tmp (vla-get-textstring (car (vlax-invoke obj 'getattributes)))))
                    )
                    (setq bln tmp)
                )
            )
            (if bln
                (if (tblsearch "block" bln)
                    (progn
                        (setq tmp 1)
                        (while (tblsearch "block" (strcat bln (itoa (setq tmp (1+ tmp))))))
                        (setq bln (strcat bln (itoa tmp)))
                    )
                )
                (setq bln "*U")
            )
            (setq doc (vla-get-activedocument (vlax-get-acad-object))
                  blk (vlax-invoke (vla-get-blocks doc) 'add bpt bln)
            )
	    (PROGN
	      (SETQ PDFUNDLAY (SSGET "_X" '((0 . "PDFUNDERLAY") (410 . "Model"))))
	      (VL-CMDF "_.draworder" PDFUNDLAY "" "front")
	    )
            (vlax-invoke doc 'copyobjects lst blk)
            (vlax-invoke
                (vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                'insertblock bpt (vla-get-name blk) 1.0 1.0 1.0 0.0
            )
            (foreach obj lst (vla-delete obj))
            (princ (strcat "\nCreated block: \"" (vla-get-name blk) "\"."))
        )
    )
    (princ)
)
(vl-load-com) (princ)

 It worked for me but that is no guarantee.

[dvanerem]

I don't think my last post went through. However this is not working. But is that because you are doing a PDFUNDERLAY and I am using actual images like jpgs. they are treated differently by autocad so maybe the way it selects it is different? 

[mid-awe]

You could just copy and paste the snippet into the command prompt. press enter and it would work, but I knew it likely had to run before the step that the block was made. It can be shortened to one line easily and do away with the local variable.

Lee can probably do it along with his variables assign the values directly to the object. Or something ?..

[dvanerem]

OK so I got this to work, my only problem now is that when the command runs it makes the block no problem, then it goes to select object after the command is run. How to I make sure that the command line is just ready for a new command once this is run?  Here is the modified code:

(defun c:qb2 ( / blk bln bpt doc idx llp lst obj sel tmp PDFUNDLAY)
(if (setq sel (ssget "_:L" (list (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")))))
(progn
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
lst (cons obj lst)
)
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq bpt (cond ((mapcar 'min bpt (vlax-safearray->list llp))) ((vlax-safearray->list llp))))
)
(if (and (null bln)
(= "AcDbBlockReference" (vla-get-objectname obj))
(= :vlax-true (vla-get-hasattributes obj))
(snvalid (setq tmp (vla-get-textstring (car (vlax-invoke obj 'getattributes)))))
)
(setq bln tmp)
)
)
(if bln
(if (tblsearch "block" bln)
(progn
(setq tmp 1)
(while (tblsearch "block" (strcat bln (itoa (setq tmp (1+ tmp))))))
(setq bln (strcat bln (itoa tmp)))
)
)
(setq bln "*U")
)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
blk (vlax-invoke (vla-get-blocks doc) 'add bpt bln)
)
(vlax-invoke doc 'copyobjects lst blk)
(vlax-invoke
(vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
'insertblock bpt (vla-get-name blk) 1.0 1.0 1.0 0.0
)
(foreach obj lst (vla-delete obj))
(PROGN
(SETQ PDFUNDLAY (SSGET "_X" '((0 . "IMAGE") (410 . "Model"))))
(VL-CMDF "_.draworder" PDFUNDLAY "back" "")
)
(princ (strcat "\nCreated block: \"" (vla-get-name blk) "\"."))
)
)
(princ)
)
(vl-load-com) (princ)

[dvanerem]

Actually the code that I put in does not acutally work. It sends it to the front when it is in the back, and when it is in the front it sends it to the back. 

[Lee_Mac]

Reversing the list of objects supplied to the copyobjects method should *hopefully* retain the draw order, however, if the following modified code doesn't work we can force draw-order of the objects within the block by other means:

(defun c:qb ( / blk bln bpt doc idx llp lst obj sel tmp )
    (if (setq sel (ssget "_:L" (list (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")))))
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                      lst (cons obj lst)
                )
                (if (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
                    )
                    (setq bpt (cond ((mapcar 'min bpt (vlax-safearray->list llp))) ((vlax-safearray->list llp))))
                )
                (if (and (null bln)
                         (= "AcDbBlockReference" (vla-get-objectname obj))
                         (= :vlax-true (vla-get-hasattributes obj))
                         (snvalid (setq tmp (vla-get-textstring (car (vlax-invoke obj 'getattributes)))))
                    )
                    (setq bln tmp)
                )
            )
            (if bln
                (if (tblsearch "block" bln)
                    (progn
                        (setq tmp 1)
                        (while (tblsearch "block" (strcat bln (itoa (setq tmp (1+ tmp))))))
                        (setq bln (strcat bln (itoa tmp)))
                    )
                )
                (setq bln "*U")
            )
            (setq doc (vla-get-activedocument (vlax-get-acad-object))
                  blk (vlax-invoke (vla-get-blocks doc) 'add bpt bln)
            )
            (vlax-invoke doc 'copyobjects (reverse lst) blk)
            (vlax-invoke
                (vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                'insertblock bpt (vla-get-name blk) 1.0 1.0 1.0 0.0
            )
            (foreach obj lst (vla-delete obj))
            (princ (strcat "\nCreated block: \"" (vla-get-name blk) "\"."))
        )
    )
    (princ)
)
(vl-load-com) (princ)

@midawe: a good effort, but using the DRAWORDER command will unfortunately not work in this case as the draw order of the objects will not necessary be retained when the ActiveX copyobjects method is evaluated to deep-clone the objects to the block definition, as the natural draw-order will depend on the order in which the new objects are added to the drawing database. And of course, the use of this command following insertion of the block will also be ineffective as the objects will be nested and hence inaccessible from AutoCAD commands & ssget.

Sorry for the delay in posting - I'm in a different timezone to you guys.

[mid-awe]

"good effort"
Thank you Lee.

"the natural draw-order will depend on the order in which the new objects are added to the drawing database."

That explains why it worked for me. I tested against the OP's sample attached above. There was no image in the file so I added one making it the last entity.

Also, the OP stated that he applies the draworder to all images in the file at the same time, and so, I would think it safe to do the same. Apparently, all images should be moved to the back regardless of the block inclusion. I was not sure if the ssget selectionset would acquire nested images too.

Thanks again.

[dvanerem]

Thank you Lee! This now works great for me! The draw order seems to retain itself how I show it which for me is great. 

The only thing that would be nice to change would be if the block name already exists I would rather put a letter behind it, like F-100a instead of F-1001, the reason being I might have another part called F-1001 and the letter would just let me review for mistakes easier so i can see where we have a conflict. Other than that this is awesome! Thank you both so much for the help!