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)
)
Solved! Go to Solution.
Solved by Lee_Mac. Go to Solution.
You're very welcome mid-awe
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.
Excellent, that's great to hear
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!
Sure, 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 "") (while (tblsearch "block" (strcat bln (setq tmp (LM:alpha++ tmp))))) (setq bln (strcat bln 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) ) ;; Alpha++ - Lee Mac ;; Increments an uppercase alphabetical string by one, e.g. AZ => BA ;; a - [str] uppercase alphabetical string (defun LM:alpha++ ( a ) ( (lambda ( f ) (vl-list->string (reverse (f (reverse (vl-string->list a)))))) (lambda ( l ) (if l (if (= 90 (car l)) (cons 65 (f (cdr l))) (cons (1+ (car l)) (cdr l)) ) '(65) ) ) ) ) (vl-load-com) (princ)
The LM:Alpha++ function is taken from my site here.
Lee