Use LISP to create block and autoselect objects with ssget

[pttr]

Hi this might be an easy one for you, im new to LISP

I want to create a block and autoselect the objects insed of manully selecting them.

This is my code:

(defun C:bltest (/)
	
  	
	
  	(command "-block" "testblock" "0,0" (ssget "_X" '((0 . "CIRCLE"))) "" )

  )

Note: circle is just for testing i want it to use existing predefined blocks from the model later.

 

 

[mhupp]

While manually selecting items to be in a block is sometimes slow. I would advice against using ssget "_X" when making block selections. it takes most of the control away from you. Yes you can filter it down but do you want all circles in the drawing to be in this one block?

 

This is a stripped down version of my quick block lisp. 

run command and promoted to name block. if you either try to name it an already existing block name or leave the name blank it will auto generate a random name like "$J34K4-2V0489". Same with the base point you can either pick it or just right click and it will be in the middle of selected entity's.

 

;;----------------------------------------------------------------------------;;
;; Quick Block - Creates Block from selected objects
(defun C:QB (/ SS blkname mpt ptslst minpt maxpt LL UR)
  (if (setq SS (ssget))
    (progn
      (if (or (eq (setq blkname (getstring T "\nBlock Name: ")) "") (/= (tblsearch "block" blkname) nil))
        (Set_blkname)
      )
      (if (not (setq MPT (getpoint "\nSpecify Base Point: ")))
        (progn
          (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
            (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
            (setq ptslst (cons (vlax-safearray->list minpt) ptslst)
                  ptslst (cons (vlax-safearray->list maxpt) ptslst)
            )
          )
          (setq LL (apply 'mapcar (cons 'min ptslst))
                UR (apply 'mapcar (cons 'max ptslst))
                MPT (mapcar '/ (mapcar '+ LL UR) '(2 2 2))
          )
        )
      )
      (vl-cmdf "_.Block" blkname "_non" MPT SS "")
      (vl-cmdf "_.Insert" blkname "_non" MPT 1 1 0)
      (prompt (strcat "\nBlock [" blkname "] Was Created."))
    )
    (prompt "\nNothing Selected")
  )
  (princ)
)
;;;========================================================================
;;;                                                                        
;;;                    *** AUTO-BLOCK.LSP ***                              
;;;     BLOCK CREATION ON THE FLY : "Just select your objects"             
;;;                                                                        
;;;               By Raymond RIZKALLAH, October/2004                       
;;;========================================================================

(defun Set_BlkName ()
  (setq o-dmzn (getvar "dimzin"))
  (setvar "dimzin" 0)
  (setq c-date (getvar "cdate"))
  (setq w-all (rtos c-date 2 20))         ;; >> "20041022.11423489"
  (setq w-yr (substr w-all 3 2))          ;; ["01" to "99"] >> "04"
  (setq w-mn (substr w-all 5 2)           ;; ["A" to "L"] >> "J"
        w-mn (chr (+ 64 (read w-mn)))     ;;
  )
  (setq w-dy (substr w-all 7 2))          ;; ["A" to "Z" + "1" to "5"] >> "V"
  (if (<= (read w-dy) 26)                 ;;
    (setq w-dy (chr (+ 64 (read w-dy))))  ;;
    (setq w-dy (rtos (- (read w-dy) 26) 2 0))  ;;
  )
  (setq w-hr (substr w-all 10 2)       ;; ["A" to "S"] >> "K"
        w-hr (chr (+ 64 (read w-hr)))  ;;
  )
  (setq w-mt (strcat (substr w-all 12 1) "-" (substr w-all 13 1)))  ;; ["00" to "59"] >> "4-2"
  (setq w-sc (substr w-all 14 2))  ;; ["00" to "59"] >> "34"
  (setq w-mm (substr w-all 16 2))  ;; ["00" to "59"] >> "89"
  (setq blkname (strcat "$" w-mn w-sc w-hr w-mt w-dy w-yr w-mm))  ;; >> "$J34K4-2V0489"
  (setvar "dimzin" o-dmzn)
  (princ)
)

 

 

Edited June 9, 2022 by mhupp

[ronjonp]

@mhupp That Set_BlkName code seems a bit overkill when you could do something as simple as this 

(defun _blockname (prefix / i r)
  (setq i 0)
  (while (tblobjname "BLOCK" (setq r (strcat prefix "_" (itoa (setq i (1+ i)))))))
  r
)
(_blockname (getenv "USERNAME"))

 

Or if you want to tie the date to the name:

(defun _blockname (prefix / r)
  (while (tblobjname
	   "BLOCK"
	   (setq r (strcat prefix "_" (menucmd "M=$(edtime, $(getvar,date),YYYY-MO-DD.MM)")))
	 )
  )
  r
)
(_blockname (getenv "USERNAME"))

 

Edited June 9, 2022 by ronjonp

[mhupp]

Yeah I originally had something like your first example. but If you move a block from one drawing into another drawing and the block name is already defined in the new drawing. It will overwrite the block to the new definition. This caused a huge headache with our production files a few years ago.

See this example.

 

So as to not run into that again its probably a bit of an over correction but i also like how all the "un-named" block are at the top of the list and the kinda match the Ctrl+Shift+V naming

 

 

 

Edited June 10, 2022 by mhupp

[exceed]

; IB - 2022.06.10 exceed 
; https://www.cadtutor.net/forum/topic/75382-use-lisp-to-create-block-and-autoselect-objects-with-ssget/
;
; make block with instant name. example is all circle

(defun C:IB ( / ss oldcmd )
  (setq oldcmd (getvar 'cmdecho))
  (if (= oldcmd 1) (setvar 'cmdecho 0))
  (if (setq ss (ssget "_X" '((0 . "CIRCLE"))))
    (progn
      (command "_.COPYBASE" "0,0" ss "")
      (command "_.ERASE" ss "")
      (command "_.PASTEBLOCK" "0,0")
      (princ "\n IB - complete")
    )
    (progn
      (princ "\n IB - there's no object for making block")
    )
  )
  (setvar 'cmdecho oldcmd)
  (princ)
)

 

how about this? this is the method using that ctrl+shift+v.

 

It might be easier to leave it to the "command" than to generate a serial number for the name. 

 

 

 

[mhupp]

Thought of that too but you end up with blocks like this.

 

 

[exceed]

1 minute ago, mhupp said:

Thought of that too but you end up with blocks like this.

 

 

 

; IB - 2022.06.10 exceed 
; https://www.cadtutor.net/forum/topic/75382-use-lisp-to-create-block-and-autoselect-objects-with-ssget/
;
; make block with instant name. example is all circle

(defun C:IB ( / ss oldcmd box midpt )
  (setq oldcmd (getvar 'cmdecho))
  (if (= oldcmd 1) (setvar 'cmdecho 0))
  (if (setq ss (ssget "_X" '((0 . "CIRCLE"))))
    (progn
      (setq box (LM:ssboundingbox ss))
      (setq midpt (list (/ (+ (car (car box)) (car (cadr box))) 2) (/ (+ (cadr (car box)) (cadr (cadr box))) 2)))
      (command "_.COPYBASE" midpt ss "")
      (command "_.ERASE" ss "")
      (command "_.PASTEBLOCK" midpt)
      (princ "\n IB - complete")
    )
    (progn
      (princ "\n IB - there's no object for making block")
    )
  )
  (setvar 'cmdecho oldcmd)
  (princ)
)

(vl-load-com)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (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 ls1 (cons (vlax-safearray->list llp) ls1)
                  ls2 (cons (vlax-safearray->list urp) ls2)
            )
        )
    )
    (if (and ls1 ls2)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    )
)

 

add function for center point as base point

how about this?

[mhupp]

3 hours ago, exceed said:

It might be easier to leave it to the "command" than to generate a serial number for the name. 

 

I don't have to do anything and it takes 1ms to generate.

Edited June 10, 2022 by mhupp

[Tharwat]

How would you guys create a block if one circle object resides in any paper space while you don't obtain / gather objects in certain space ?

[ronjonp]

13 hours ago, mhupp said:

Yeah I originally had something like your first example. but If you move a block from one drawing into another drawing and the block name is already defined in the new drawing. It will overwrite the block to the new definition. This caused a huge headache with our production files a few years ago.

See this example.

The date version would probably solve that

[rcb007]

On 6/9/2022 at 9:05 PM, exceed said:

 

; IB - 2022.06.10 exceed 
; https://www.cadtutor.net/forum/topic/75382-use-lisp-to-create-block-and-autoselect-objects-with-ssget/
;
; make block with instant name. example is all circle

(defun C:IB ( / ss oldcmd box midpt )
  (setq oldcmd (getvar 'cmdecho))
  (if (= oldcmd 1) (setvar 'cmdecho 0))
  (if (setq ss (ssget "_X" '((0 . "CIRCLE"))))
    (progn
      (setq box (LM:ssboundingbox ss))
      (setq midpt (list (/ (+ (car (car box)) (car (cadr box))) 2) (/ (+ (cadr (car box)) (cadr (cadr box))) 2)))
      (command "_.COPYBASE" midpt ss "")
      (command "_.ERASE" ss "")
      (command "_.PASTEBLOCK" midpt)
      (princ "\n IB - complete")
    )
    (progn
      (princ "\n IB - there's no object for making block")
    )
  )
  (setvar 'cmdecho oldcmd)
  (princ)
)

(vl-load-com)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (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 ls1 (cons (vlax-safearray->list llp) ls1)
                  ls2 (cons (vlax-safearray->list urp) ls2)
            )
        )
    )
    (if (and ls1 ls2)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    )
)

 

add function for center point as base point

how about this?

 

I am trying to figure out how to set the bounding box (basepoint) to the bottom left of the selected objects? I am having a hard time following the caar, cadar, caadr, cadadr. lol.

 

; IB - 2022.06.10 exceed 
; https://www.cadtutor.net/forum/topic/75382-use-lisp-to-create-block-and-autoselect-objects-with-ssget/

(defun C:CreateNamedBLock ( / ss box llpt )  ;;llpt lower left point
(setq ss (ssget))
      (setq box (LM:ssboundingbox ss))
      ;;(setq midpt (list (/ (+ (car (car box)) (car (cadr box))) 2) (/ (+ (cadr (car box)) (cadr (cadr box))) 2))) <=original
      (setq llpt (list (/ (+ (car (cadr box)) (car (cadr box))) 2) (/ (+ (cadr (car box)) (cadr (cadr box))) 2)))
      ;;'((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr)) <=== examples
      (command "_.COPYBASE" llpt ss "")
      (command "_.ERASE" ss "")
      (command "_.PASTEBLOCK" llpt)
(princ))

 

Thank you for the help. Hopefully its me not understanding. 

Edited December 12, 2022 by rcb007

[mhupp]

(if (setq ss (ssget))
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)  ;gets LL and UR of all entitys in selection set
    (setq ptslst (cons (vlax-safearray->list minpt) ptslst)          
          ptslst (cons (vlax-safearray->list maxpt) ptslst)          
    )
  )
)
(setq LL (apply 'mapcar (cons 'min ptslst)) ;calculates the new LL from ptslst 
      UR (apply 'mapcar (cons 'max ptslst)) ;calculates the new UR from ptslst
      MPT (mapcar '/ (mapcar '+ LL UR) '(2 2 2)) ;once new LL and UR are found you can calculate the Mid Point
)  

(command "_.COPYBASE" "_non" LL ss "")
(command "_.ERASE" ss "")
(command "_.PASTEBLOCK" "_non" LL)

 

either use "_non" or osmode 0 when using points with command so things don't snap to close entity's

Edited December 12, 2022 by mhupp

[rcb007]

Thanks mhupp for the tip. Also, thank you for clarifying how the location is defined.