Topic: Lisp error for draw a rectangle bounding box in multiple block

[dimka]

Hello everyone, I am new learn to Lisp. I tried to modify a lisp to draw a rectangular bounding box in multiple blocks, i have a thousand block in a drawing. but I have no idea to modified this lisp problem.

The following error is this:

46.png(every block should it own bounding box)

but

45.png(the error is all block bounding box include each others. it mess up)

i wish some one lisp expert can help me to accomplish. thanks all.

Code: [Select]

(defun c:rblk (/ ss minpt maxpt eLL eUR LL UR)

  (setq lst nil)
  (while (setq def (tblnext "block" (not def)))
    (if (zerop (logand 125 (cdr (assoc 70 def))))
      (setq lst (cons (cdr (assoc 2 def)) lst))
      )
    )
  (setq ntotal (length lst))
  (princ (strcat "Number of blocks: " (itoa ntotal)))
 

  (setq lstlength(length lst)) ;; Determine how many blocks are in the drawing - to iterate through them
  (setq n 0) ;; initialize the counter
  (cond (lst ;; Verify that we have blocks at all.
(repeat lstlength ;; Iterate through each item in the list of blocks.
   ;;(princ (strcat "Editing block: " (nth n lst)))
   (command-s "_.bedit" (nth n lst)) ;; bedit a block
 
          ;(setq ss nil)
           


 (vl-load-com)

 (setq lay "My Boxing Layer" ;; Layer

       offset 3.  ;; Offset

       thgt 0   ;; Text Height / position

 )

 (defun *error* (msg)
   (and uFlag (vla-EndUndomark *doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 
 (defun LWPoly (lst cls)
   (entmakex (append (list (cons 0 "LWPOLYLINE")
                           (cons 100 "AcDbEntity")
                           (cons 100 "AcDbPolyline")
                           (cons 8 lay)
                           (cons 90 (length lst))
                           (cons 70 cls))
                     (mapcar (function (lambda (p) (cons 10 p))) lst))))

 (defun Text (pt hgt str)
   (entmakex (list (cons 0 "TEXT")
                   (cons 8 lay)
                   (cons 10  pt)
                   (cons 40 hgt)
                   (cons 1  str)
                   (cons 72 1)
                   (cons 73 2)
                   (cons 11 pt))))

 (setq *doc (cond (*doc) ((vla-get-ActiveDocument
                            (vlax-get-acad-object)))))
 

(if (setq ss (ssget "_X"))
   (progn
     (setq uFlag (not (vla-StartUndoMark *doc)))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))
       
       (vla-getBoundingbox obj 'Mi 'Ma)
       (setq pts (cons (vlax-safearray->list Mi)
                       (cons (vlax-safearray->list Ma) pts))))
     (vla-delete ss)
     (setq Mi (apply (function mapcar) (cons 'min pts))
           Ma (apply (function mapcar) (cons 'max pts)))

     (setq Poly
       (LwPoly (list (list (- (car Mi) offset)
                           (- (cadr Mi) Offset) 0.)
                     (list (- (car Mi) offset)
                           (+ (cadr Ma) offset) 0.)
                     (list (+ (car Ma) offset)
                           (+ (cadr Ma) offset) 0.)
                     (list (+ (car Ma) offset)
                           (- (cadr Mi) offset) 0.)) 1))

     (setq num
       (if (setq i -1 floor 1 ss (ssget "_X" (list (cons 0 "TEXT") (cons 8 lay))))
         (progn
           (while (setq ent (ssname ss (setq i (1+ i))))
             (if (< floor (setq nNum (atoi (cdr (assoc 1 (entget ent))))))
               (setq floor nNum)))

           (itoa (1+ floor))) "1"))

     (setq TObj
       (Text (list (/ (+ (car Mi) (car Ma)) 2.)
                   (+ (cadr Mi) (+ Offset tHgt)) 0.) thgt num))



     (if (not (vl-catch-all-error-p
                (setq Grp
                  (vl-catch-all-apply
                    (function vla-Add)
                      (list (vla-get-Groups *doc) (strcat "BoxNumber_" num))))))
       
       (vla-AppendItems Grp
         (vlax-make-variant
           (vlax-safearray-fill
             (vlax-make-safearray
               vlax-vbObject '(0 . 1))
             (mapcar
               (function vlax-ename->vla-object) (list Poly tObj)))))

       (princ (strcat "\n** Error Creating Group: "
                      (vl-catch-all-error-message Grp) " **")))
     
     (setq uFlag (vla-EndUndoMark *doc))))     

 (princ)




   (terpri) (princ (strcat "Completed " (itoa (1+ n)) " out of " (itoa ntotal))) ;; progress updates
   (setq n (1+ n)) ;; 1+ on the iterative counter
   (command-s "_.bsave") ;; save the block
   )
(command-s "_.bclose" "_sav")
)
)
  (terpri)
  )





[mkweaver]

I think this will give you most of what you're looking for.  You will need to specify the text string you want for your text object.
You will also need ToList.lsp - attached.

Code - Auto/Visual Lisp: [Select]

1. (defun c:rblk (/ doc BDefs)
2.   (setq doc   (vla-get-activedocument (vlax-get-acad-object))
3.         BDefs (cddr (tolist (vla-get-blocks doc)))
4.   )
5.   (princ (strcat "\n" (itoa (length BDefs)) " block definitions found."))
6.   (foreach bdef bdefs
7.     (princ
8.       (strcat "\nAdding bounding box and label to block: " (vla-get-name bdef))
9.     )
10.     (MakeBoundingBox bdef 3)
11.   )
12.   (princ)
13. )
14.  
15.  
16.  
17. ;; Selection Set Bounding Box
18. ;; Derived from LM:ssboundingbox by Lee Mac
19. ;; Returns a list of the lower-left and upper-right WCS coordinates of a
20. ;; rectangular frame bounding all objects in a supplied selection set.
21. ;; sel - [sel] Selection set for which to return bounding box
22. ;;
23. ;; Modifications made by Mike Weaver, 5/31/19, to accept a list of
24. ;; enames/vla-objects instead of a selection set
25. (defun LM:mkw:ssboundingbox (sel / idx llp ls1 ls2 obj urp)
26.   (if (= 'PICKSET (type sel))
27.     (setq sel (tolist sel))
28.   )
29.   (setq sel (mapcar (function (lambda (obj)
30.                                 (if (= 'ENAME (type obj))
31.                                   (vlax-ename->vla-object obj)
32.                                   obj
33.                                 )
34.                               )
35.                     )
36.                     (tolist sel)
37.             )
38.   )
39.   (repeat (setq idx (length sel))
40.     (setq obj (nth (setq idx (1- idx)) sel))
41.     (if
42.       (and (vlax-method-applicable-p obj 'getboundingbox)
43.            (not (vl-catch-all-error-p
44.                   (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))
45.                 )
46.            )
47.       )
48.        (setq ls1 (mapcar 'min
49.                          (vlax-safearray->list llp)
50.                          (cond (ls1)
51.                                ((vlax-safearray->list llp))
52.                          )
53.                  )
54.              ls2 (mapcar 'max
55.                          (vlax-safearray->list urp)
56.                          (cond (ls2)
57.                                ((vlax-safearray->list urp))
58.                          )
59.                  )
60.        )
61.     )
62.   )
63.   (if (and ls1 ls2)
64.     (list ls1 ls2)
65.   )
66. )
67.  
68. (defun MakeBoundingBox (bdef Offset / obj pts p0 p1 p2 p3 TextPT)
69.   (setq pts    (LM:mkw:ssboundingbox (tolist bdef))
70.         p0     (car pts)
71.         p2     (cadr pts)
72.         p0     (list (- (car p0) offset) (- (cadr p0) offset))
73.         p2     (list (+ (car p2) offset) (+ (cadr p2) offset))
74.         p1     (list (car p2) (cadr p0))
75.         p3     (list (car p0) (cadr p2))
76.         pts    (vlax-make-safearray vlax-vbdouble '(0 . 7))
77.         TextPT (mapcar (function (lambda (ord1 ord2) (/ (+ ord1 ord2) 2.0))) p0 p2)
78.   )
79.   (vlax-safearray-fill pts (apply 'append (list p0 p1 p2 p3)))
80.   (setq obj (vla-AddLightWeightPolyline bdef pts))
81.   (vla-put-closed obj :vlax-true)
82.   (setq objText (MakeText bdef
83.                           TextPT ;mid point of the block
84.                           (/ (+ (cadr p0) (cadr p2)) 2.0) ;text height half the height of the block
85.                           (vla-get-name bdef)   [color=red][b];Specify your text string here[/b][/color]
86.                 )
87.   )
88.   (list obj objText)
89. )                             ;end defun MakeBoundingBox
90.  
91.  
92.  
93.  
94.  
95. (defun MakeText (bdef TextPT hgt str / obj)
96.   (setq obj (vla-addtext bdef
97.                          str
98.                          (vlax-3d-point (list (car TextPT) (cadr TextPT) 0))
99.                          hgt
100.             )
101.   )
102.   (vla-put-stylename obj (getvar "textstyle"))
103.   obj
104. )
105.  
106.  
107.