Lisp to create a boundary around blocks that are not touching.

[rdarger]

On 9/17/2017 at 4:24 AM, Lee Mac said:

I have the following, but there are still some bugs -

 

Where do I find the code for this Lee?

[rdarger]

On 10/29/2021 at 8:57 AM, mrigorh said:

 

Never mind, just found it. Thanks!

Where did you find it?

[Lee Mac]

1 hour ago, rdarger said:

Where do I find the code for this Lee?

 

Per this comment earlier in the thread, I've not released this code as it doesn't perform successfully for all cases.

[vemuribalaji]

On 7/25/2022 at 10:26 PM, rdarger said:

Where do I find the code for this Lee?

Where do I find the code for this Lee?

[SLW210]

3 hours ago, vemuribalaji said:

Where do I find the code for this Lee?

Did you read his last post? He hasn't released it, so it is not available at this time.

[aaron.gonzalez]

On 9/17/2017 at 5:24 AM, Lee Mac said:

I have the following, but there are still some bugs -

 

 

Lee, could you share the code for objects solution? (no blocks) please

[BIGAL]

I think there was a similar request recently over at forums/autodesk, some solutions were offered. Will try to find.

Edited October 26, 2023 by BIGAL

[exceed]

 

(vl-load-com)
(defun c:wrap ( / acdoc *error* oldcmdecho ss0 ssl0 index ent bb ss 
               ssl ptlist elist pt1 ptlist chlist chent textflag obj 
               box lll url )
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq oldcmdecho (getvar 'cmdecho))
  (defun *error* ( msg )
    (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (princ (strcat "\n Error: " msg))
    )
    (vla-EndUndoMark acdoc)
    (setvar 'cmdecho oldcmdecho)
    (princ)
  ) 
  (defun LWPolybylist (lst cls) 
    (entmakex 
      (append 
        (list 
          (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 90 (length lst))
          (cons 70 cls)
        )
        (mapcar (function (lambda (p) (cons 10 p))) lst)
      )
    )
  )

  (vla-StartUndoMark acdoc)
  (setvar 'cmdecho 0)
  (setq ss0 (ssget))
  (setq ssl0 (sslength ss0))
  (setq index 0)
  (setq textflag 0)
  (setq ptlist '())
  (repeat ssl0
    (setq ent (ssname ss0 index))
    (setq elist (entget ent))
    (if (or (eq (cdr (assoc 0 elist)) "TEXT") (eq (cdr (assoc 0 elist)) "MTEXT") (eq (cdr (assoc 0 elist)) "INSERT"))
      (progn
        (setq textflag 1)
        (setq obj (vlax-ename->vla-object ent))
        (setq box (vla-getboundingbox obj 'll 'ur))
        (setq lll (vlax-safearray->list ll)) ; lower left point
        (setq url (vlax-safearray->list ur)) ; upper right point
        (setq ent (LWPolybylist (list lll (list (car url) (cadr lll)) url (list (car lll) (cadr url))) 1))
      )
      (progn
        
      )
    ) 
    (setq ptlist (append (LM:ent->pts ent 100) ptlist))
    ;(command "_.DIVIDE" ent 100 "")
    (if (= textflag 1)
      (entdel ent)
    )
    (setq textflag 0)
    (setq index (+ index 1))
  )
  (setvar 'cmdecho oldcmdecho)
  (setq bb (LM:ssboundingbox ss0))
  ;(if (setq ss (ssget "_C" (car bb) (cadr bb) '((0 . "POINT"))))
  ;  (progn 
  ;    (setq ssl (sslength ss))
  ;    (setq index 0)
  ;    (repeat ssl
  ;      (setq ent (ssname ss index))
  ;      (setq elist (entget ent))
  ;      (setq pt1 (cdr (assoc 10 elist)))
  ;      (setq ptlist (cons pt1 ptlist))
  ;      (entdel ent)
  ;      (setq index (+ index 1))
  ;    )
  ;  )
  ;)
  

  ;(princ ptlist)
  (setq chlist (LM:ConvexHull ptlist))
  (setq chent (entmakex
                (append
                    (list
                       '(000 . "LWPOLYLINE")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbPolyline")
                        (cons 90 (length chlist))
                       '(070 . 1)
                    )
                    (mapcar '(lambda ( x ) (cons 10 x)) chlist)
                )
            )
  )
  (vla-EndUndoMark acdoc)
  (princ)
)

;; Convex Hull  -  Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.

(defun LM:ConvexHull ( lst / ch p0 )
    (cond
        (   (< (length lst) 4) lst)
        (   (setq p0 (car lst))
            (foreach p1 (cdr lst)
                (if (or (< (cadr p1) (cadr p0))
                        (and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
                    )
                    (setq p0 p1)
                )
            )
            (setq lst
                (vl-sort lst
                    (function
                        (lambda ( a b / c d )
                            (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
                                (< (distance p0 a) (distance p0 b))
                                (< c d)
                            )
                        )
                    )
                )
            )
            (setq ch (list (caddr lst) (cadr lst) (car lst)))
            (foreach pt (cdddr lst)
                (setq ch (cons pt ch))
                (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
                    (setq ch (cons pt (cddr ch)))
                )
            )
            ch
        )
    )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                 
(defun LM:Clockwise-p ( p1 p2 p3 )
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
        )
        1e-8
    )
)

;; 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))
    )
)

;; Entity to Point List  -  Lee Mac
;; Returns a list of WCS points describing or approximating the supplied entity, else nil if the entity is not supported.
;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE)
;; acc - [num] Positive number determining the point density for non-linear objects

(defun LM:ent->pts (ent acc / ang bul cen cls di1 di2 enx inc itm lst num ocs rad tot 
                    typ vt1 vt2 vtl
                   ) 
  (setq enx (entget ent)
        typ (cdr (assoc 0 enx))
  )
  (cond 
    ((= "POINT" typ)
     (list (cdr (assoc 10 enx)))
    )
    ((= "LINE" typ)
     (mapcar '(lambda (x) (cdr (assoc x enx))) '(10 11))
    )
    ((or (= "ARC" typ) (= "CIRCLE" typ))
     (if (= "ARC" typ) 
       (setq ang (cdr (assoc 50 enx))
             tot (rem (+ pi pi (- (cdr (assoc 51 enx)) ang)) (+ pi pi))
             num (fix (+ 1.0 1e-8 (* acc (/ tot (+ pi pi)))))
             inc (/ tot (float num))
             num (1+ num)
       )
       (setq ang 0.0
             tot (+ pi pi)
             num (fix (+ 1e-8 acc))
             inc (/ tot (float num))
       )
     )
     (setq cen (cdr (assoc 010 enx))
           rad (cdr (assoc 040 enx))
           ocs (cdr (assoc 210 enx))
     )
     (repeat num 
       (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
             ang (+ ang inc)
       )
     )
     (reverse lst)
    )
    ((or (= "LWPOLYLINE" typ) 
         (and (= "POLYLINE" typ) 
              (zerop (logand (logior 16 64) (cdr (assoc 70 enx))))
         )
     )
     (if (= "LWPOLYLINE" typ) 
       (setq vtl (LM:ent->pts:lwpolyvertices enx))
       (setq vtl (LM:ent->pts:polyvertices ent))
     )
     (if 
       (setq ocs (cdr (assoc 210 enx))
             cls (= 1 (logand 1 (cdr (assoc 70 enx))))
       )
       (setq vtl (append vtl (list (cons (caar vtl) 0.0))))
     )
     (while (setq itm (car vtl)) 
       (setq vtl (cdr vtl)
             vt1 (car itm)
             bul (cdr itm)
             lst (cons (trans vt1 ocs 0) lst)
       )
       (if (and (not (equal 0.0 bul 1e-8)) (setq vt2 (caar vtl))) 
         (progn 
           (setq rad (/ (* (distance vt1 vt2) (1+ (* bul bul))) 4.0 bul)
                 cen (polar vt1 
                            (+ (angle vt1 vt2) (- (/ pi 2.0) (* 2.0 (atan bul))))
                            rad
                     )
                 rad (abs rad)
                 tot (* 4.0 (atan bul))
                 num (fix (+ 1.0 1e-8 (* acc (/ (abs tot) (+ pi pi)))))
                 inc (/ tot (float num))
                 ang (+ (angle cen vt1) inc)
           )
           (repeat (1- num) 
             (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
                   ang (+ ang inc)
             )
           )
         )
       )
     )
     (reverse (if cls (cdr lst) lst))
    )
    ((= "ELLIPSE" typ)
     (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
           di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
           di2 (- di2 1e-8)
     )
     (while (< di1 di2) 
       (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
             rad (distance '(0.0 0.0) 
                           (vlax-curve-getfirstderiv ent 
                                                     (vlax-curve-getparamatdist ent 
                                                                                di1
                                                     )
                           )
                 )
             di1 (+ di1 (/ di2 (1+ (fix (* acc (/ di2 rad (+ pi pi)))))))
       )
     )
     (reverse 
       (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst))
     )
    )
    ((= "SPLINE" typ)
     (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
           di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
           lst (list (vlax-curve-getstartpoint ent))
           inc (/ (- di2 di1) (float acc))
           di1 (+ di1 inc)
     )
     (repeat (1- (fix (+ 1e-8 acc))) 
       (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
             di1 (+ di1 inc)
       )
     )
     (reverse 
       (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst))
     )
    )
  )
)

(defun LM:ent->pts:lwpolyvertices (enx / elv lst vtx) 
  (setq elv (list (cdr (assoc 38 enx))))
  (while (setq vtx (assoc 10 enx)) 
    (setq enx (cdr (member vtx enx))
          lst (cons (cons (append (cdr vtx) elv) (cdr (assoc 42 enx))) lst)
    )
  )
  (reverse lst)
)

(defun LM:ent->pts:polyvertices (ent / lst vte vtx) 
  (setq vte (entnext ent)
        vtx (entget vte)
  )
  (while (= "VERTEX" (cdr (assoc 0 vtx))) 
    (setq lst (cons (cons (cdr (assoc 10 vtx)) (cdr (assoc 42 vtx))) lst)
          vte (entnext vte)
          vtx (entget vte)
    )
  )
  (reverse lst)
)

 

this routine wraps edges together rather than connecting right angle extension lines, so it may not suit your purpose..... so this is just for reference.

 

I personally used this when I wanted to combine separate areas while using UNION for REVCLOUD command.

Edited October 26, 2023 by exceed

[BIGAL]

Very impressive, a hard task to solve.

[SLW210]

Very nice!!

[Lee Mac]

On 10/26/2023 at 5:11 AM, aaron.gonzalez said:

Lee, could you share the code for objects solution? (no blocks) please

 

On 7/25/2022 at 7:03 PM, Lee Mac said:

Per this comment earlier in the thread, I've not released this code as it doesn't perform successfully for all cases.