Block by windowing lisp

[BrianTFC]

Hi All,

 

What i'm looking to do is block multiple objects by windowing all of them at once and have them save as sepearate blocks and using the label in the middle as the block name. I guess the big question is it even possible to do this?

 

 

Brian

block dwg.dwg

[Tharwat]

I guess it is possible since that you have a polyline all around the objects within .

 

But what's if there wasn't any text within that outside polyline to be the block name ? besides that , the text may have the same string ,

what would be the block name for the second block name ?

[BrianTFC]

They will always have a text label inside the polyline. The labels will always be different, i sorry i forgot to change the labels in my drawing after i copied them over.

[Tharwat]

Try this code Brian and I hope it would meet your needs .

 

(defun c:Test (/ *error* s i sad sn ss cm j ssn st p p1 p2 k)
 (vl-load-com)
;;; Tharwat 20. March. 2013 ;;;
 (defun *error* (x)
   (if cm
     (setvar 'cmdecho cm)
   )
   (princ "\n*Cancel*")
 )
 (if (setq s (ssget "_:L"))
   (repeat (setq i (sslength s))
     (setq sn (ssname s (setq i (1- i))))
     (if (eq (cdr (assoc 0 (entget sn))) "LWPOLYLINE")
       (progn
         (setq sad nil)
         (vla-getboundingbox (vlax-ename->vla-object sn) 'a 'b)
         (setq p (mapcar '(lambda (m n) (/ (+ m n) 2.))
                         (setq p1 (vlax-safearray->list a))
                         (setq p2 (vlax-safearray->list b))
                 )
               k 0
         )
         (if (setq ss (ssget "_CP"
                             (list p1
                                   (list (car p1) (cadr p2))
                                   p2
                                   (list (car p2) (cadr p1))
                             )
                      )
             )
           (progn (setq cm  (getvar 'cmdecho)
                        sad (ssadd)
                  )
                  (setvar 'cmdecho 0)
                  (repeat (setq j (sslength ss))
                    (setq ssn (ssname ss (setq j (1- j))))
                    (ssadd ssn sad)
                    (if (wcmatch (cdr (assoc 0 (entget ssn))) "*TEXT")
                      (setq st (cdr (assoc 1 (entget ssn))))
                    )
                  )
                  (while (tblsearch "BLOCK" st)
                    (setq st (strcat st (itoa (setq k (1+ k)))))
                  )
                  (ssadd sn sad)
                  (vl-cmdf "_.-block" st "_non" p sad "")
                  (setvar 'cmdecho cm)
           )
         )
       )
     )
   )
   (princ)
 )
 (princ)
)

[BrianTFC]

Tharwat,

 

That works great Thanks, i notice if i have more than one text string in each rectangle it makes multiple block copies. Is there a way to have it use the DTEXT label as the file name and not the other MTEXT letters in the rectangle?

 

Brian

[Tharwat]

Tharwat,

 

That works great Thanks

Brian

 

You're welcome Brian .

 

i notice if i have more than one text string in each rectangle it makes multiple block copies. Is there a way to have it use the DTEXT label as the file name and not the other MTEXT letters in the rectangle?

 

Yes sure , just remove the asterisk from the line of code from the routine .

(if (wcmatch (cdr (assoc 0 (entget ssn))) "[color=blue][b]*[/b][/color]TEXT")

 

Good luck .

[BrianTFC]

Tharwat,

 

That did the trick...I want to THANK YOU so much this save hours of work.

 

Brian

[Tharwat]

Tharwat,

 

That did the trick...I want to THANK YOU so much this save hours of work.

 

Brian

 

You're welcome .

 

I am very happy to hear that Brian .

[BrianTFC]

Tharwat,

 

I was wondering if you could modify the lisp to WBLOCK them instead of just blocking them.

 

Thanks for all of your help.

Brian

[Tharwat]

I was wondering if you could modify the lisp to WBLOCK them instead of just blocking them.

 

Hi Brian .

 

Please try this code and let me know how it goes .

 

(defun c:Test (/ doc *error* s i sad sn ss cm j ssn st p p1 p2 k lst ss l)
 (vl-load-com)
;;; Tharwat 27. March. 2013 ;;;
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (defun *error* (x)
   (if cm
     (setvar 'cmdecho cm)
   )
   (princ "\n*Cancel*")
 )
 (if (setq s (ssget "_:L"))
   (repeat (setq i (sslength s))
     (setq sn (ssname s (setq i (1- i))))
     (if (eq (cdr (assoc 0 (entget sn))) "LWPOLYLINE")
       (progn (setq sad nil)
              (vla-getboundingbox (vlax-ename->vla-object sn) 'a 'b)
              (setq p (mapcar '(lambda (m n) (/ (+ m n) 2.))
                              (setq p1 (vlax-safearray->list a))
                              (setq p2 (vlax-safearray->list b))
                      )
                    k 0
              )
              (if (setq ss (ssget "_CP" (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1)))))
                (progn (setq cm  (getvar 'cmdecho)
                             sad (ssadd)
                       )
                       (setvar 'cmdecho 0)
                       (repeat (setq j (sslength ss))
                         (setq ssn (ssname ss (setq j (1- j))))
                         (ssadd ssn sad)
                         (if (wcmatch (cdr (assoc 0 (entget ssn))) "TEXT")
                           (setq st (cdr (assoc 1 (entget ssn))))
                         )
                       )
                       (while (tblsearch "BLOCK" st) (setq st (strcat st (itoa (setq k (1+ k))))))
                       (ssadd sn sad)
                       (vl-cmdf "_.-block" st "_non" p sad "")
                       (if st
                         (setq lst (cons st lst))
                       )
                       (setvar 'cmdecho cm)
                )
              )
       )
     )
   )
   (princ)
 )
 (if lst
   (progn (foreach b lst
            (setq
              l (cons (entmakex (list '(0 . "INSERT") (list 10 0. 0. 0.) (cons 2 b) '(41 . 1.0) '(42 . 1.0) '(43 . 1.0)))
                      l
                )
            )
          )
          (foreach x lst
            (if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 x))))
              (vla-wblock doc (strcat (getvar 'dwgprefix) x ".dwg") (vla-get-activeselectionset doc))
            )
          )
          (if l
            (mapcar 'entdel l)
          )
   )
 )
 (princ "\nWritten by Tharwat Al Shoufi")
 (princ)
)

[BrianTFC]

Tharwat,

 

It works great Thank You!!! so much for all of your help.

 

Brian

[Tharwat]

Tharwat,

 

It works great Thank You!!! so much for all of your help.

 

Brian

 

You're welcome anytime .

[BrianTFC]

Tharwat,

 

I hate to ask but can you add an alert: ".dwg already exists in the current directory!!!" if try to save it again?

 

Thanks,

Brian

[Tharwat]

I hate to ask ....

 

No worries Brian , as long as I have the ability to write the code , I won't hesitate to help you at all .

 

Please try this modified lisp and hope you like the idea of the code . [ untested code ] .

 

(defun c:Test
      (/ doc *error* s i sad sn ss cm j ssn st p p1 p2 k lst ss l)
 (vl-load-com)
;;; Tharwat 27. March. 2013 ;;;
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (defun *error* (x)
   (if cm
     (setvar 'cmdecho cm)
   )
   (princ "\n*Cancel*")
 )
 (if (setq s (ssget "_:L"))
   (repeat (setq i (sslength s))
     (setq sn (ssname s (setq i (1- i))))
     (if (eq (cdr (assoc 0 (entget sn))) "LWPOLYLINE")
       (progn
         (setq sad nil)
         (vla-getboundingbox (vlax-ename->vla-object sn) 'a 'b)
         (setq p (mapcar '(lambda (m n) (/ (+ m n) 2.))
                         (setq p1 (vlax-safearray->list a))
                         (setq p2 (vlax-safearray->list b))
                 )
               k 0
         )
         (if (setq ss (ssget "_CP"
                             (list p1
                                   (list (car p1) (cadr p2))
                                   p2
                                   (list (car p2) (cadr p1))
                             )
                      )
             )
           (progn
             (setq cm  (getvar 'cmdecho)
                   sad (ssadd)
             )
             (setvar 'cmdecho 0)
             (repeat (setq j (sslength ss))
               (setq ssn (ssname ss (setq j (1- j))))
               (ssadd ssn sad)
               (if (wcmatch (cdr (assoc 0 (entget ssn))) "TEXT")
                 (setq st (cdr (assoc 1 (entget ssn))))
               )
             )
             (while (tblsearch "BLOCK" st)
               (setq st (strcat st (itoa (setq k (1+ k)))))
             )
             (ssadd sn sad)
             (if
               (not (findfile (strcat (getvar 'dwgprefix) st ".dwg")))
                (progn
                  (vl-cmdf "_.-block" st "_non" p sad "")
                  (setq lst (cons st lst))
                )
                (alert (strcat "<!> The name of the drawing < "
                               st
                               " > is already exists <!> "
                       )
                )
             )
             (setvar 'cmdecho cm)
           )
         )
       )
     )
   )
   (princ)
 )
 (if lst
   (progn
     (foreach b lst
       (setq l (cons (entmakex (list '(0 . "INSERT")
                                     (list 10 0. 0. 0.)
                                     (cons 2 b)
                                     '(41 . 1.0)
                                     '(42 . 1.0)
                                     '(43 . 1.0)
                               )
                     )
                     l
               )
       )
     )
     (foreach x lst
       (if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 x))))
         (vla-wblock
           doc
           (strcat (getvar 'dwgprefix) x ".dwg")
           (vla-get-activeselectionset doc)
         )
       )
     )
     (if l
       (mapcar 'entdel l)
     )
   )
 )
 (princ "\nWritten by Tharwat Al Shoufi")
 (princ)
)

Edited March 27, 2013 by Tharwat

[BrianTFC]

Tharwat,

 

Is there a way for it to check to see if the drawing already exists before it blocks the item? by the time it gets to wblock its already been made a block and has disappeared off my screen. i would like for it to stop the block process if it finds that the drawing already exists, is this possible?

 

Thanks,

Brian

[Tharwat]

Tharwat,

 

Is there a way for it to check to see if the drawing already exists before it blocks the item?

 

Sure , and the following code would check if the drawing is already existed in the same path which is come from the system variable 'dwgprefix .

 

(not (findfile (setq fl (strcat (getvar 'dwgprefix) x ".dwg"))))

[BrianTFC]

this is true but it still blocking the item before it gets to this line of code.

(not (findfile (setq fl (strcat (getvar 'dwgprefix) x ".dwg"))))

[Tharwat]

this is true but it still blocking the item before it gets to this line of code.

(not (findfile (setq fl (strcat (getvar 'dwgprefix) x ".dwg"))))

 

Does it mean that you don't want the code to block the objects if the future name of the block being found in the dwgprefix path ?

[BrianTFC]

Yes, is that possible?

[Tharwat]

Yes, is that possible?

 

Sure , please check the UPDATED CODES in post No. 14 and let me know how it goes with you .