Author Topic: Lisp error for draw a rectangle bounding box in multiple block  (Read 209 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.  (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))
  43. )
  44.   )
  45.      )
  46.       (setq ls1 (mapcar 'min
  47. (vlax-safearray->list llp)
  48. (cond (ls1)
  49.       ((vlax-safearray->list llp))
  50. )
  51. )
  52.     ls2 (mapcar 'max
  53. (vlax-safearray->list urp)
  54. (cond (ls2)
  55.       ((vlax-safearray->list urp))
  56. )
  57. )
  58.       )
  59.    )
  60.  )
  61.  (if (and ls1 ls2)
  62.    (list ls1 ls2)
  63.  )
  64. )
  65.  
  66. (defun MakeBoundingBox (bdef Offset / obj pts p0 p1 p2 p3 TextPT)
  67.  (setq pts    (LM:mkw:ssboundingbox (tolist bdef))
  68. p0     (car pts)
  69. p2     (cadr pts)
  70. p0     (list (- (car p0) offset) (- (cadr p0) offset))
  71. p2     (list (+ (car p2) offset) (+ (cadr p2) offset))
  72. p1     (list (car p2) (cadr p0))
  73. p3     (list (car p0) (cadr p2))
  74. pts    (vlax-make-safearray vlax-vbdouble '(0 . 7))
  75. TextPT (mapcar (function (lambda (ord1 ord2) (/ (+ ord1 ord2) 2.0))) p0 p2)
  76.  )
  77.  (vlax-safearray-fill pts (apply 'append (list p0 p1 p2 p3)))
  78.  (setq obj (vla-AddLightWeightPolyline bdef pts))
  79.  (vla-put-closed obj :vlax-true)
  80.  (setq objText (MakeText bdef
  81.  TextPT ;mid point of the block
  82.  (/ (+ (cadr p0) (cadr p2)) 2.0) ;text height half the height of the block
  83.  (vla-get-name bdef)   [color=red][b];Specify your text string here[/b][/color]
  84. )
  85.  )
  86.  (list obj objText)
  87. )      ;end defun MakeBoundingBox
  88.  
  89.  
  90.  
  91.  
  92.  
  93. (defun MakeText (bdef TextPT hgt str / obj)
  94.  (setq obj (vla-addtext bdef
  95. str
  96. (vlax-3d-point (list (car TextPT) (cadr TextPT) 0))
  97. hgt
  98.    )
  99.  )
  100.  (vla-put-stylename obj (getvar "textstyle"))
  101.  obj
  102. )
  103.  
  104.  
  105.