Author Topic: Lisp error for draw a rectangle bounding box in multiple block  (Read 316 times)

0 Members and 1 Guest are viewing this topic.

dimka

  • Mosquito
  • Posts: 1
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

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