;;; ---------------------------------------------------------------------------
;;; ShrinkWrap.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Generates closed polylines outlining ANY selection of objects - including
;;; text, blocks, hatches and dimensions, which the BOUNDARY command alone
;;; cannot trace.
;;;
;;; The usual reason for wanting this is to build a wipeout, a clipping
;;; boundary or a hatch region that follows the true silhouette of a group of
;;; objects rather than a crude rectangle around them.
;;;
;;; HOW IT WORKS - THE ISLAND TRICK
;;; The BOUNDARY command traces the empty space it is given a seed point in,
;;; and reports the "islands" it finds inside that space. This routine turns
;;; that inside out to get an outline:
;;;
;;;   1. Measure the overall bounding box of the selection.
;;;   2. Draw a temporary rectangle a comfortable margin OUTSIDE that box.
;;;   3. Drop a BOUNDARY seed point in the gap between the rectangle and the
;;;      objects - empty space that completely surrounds everything.
;;;   4. BOUNDARY traces that surrounding space and reports every island in it.
;;;      Those islands ARE the outlines of the selected objects.
;;;   5. Discard the one result that matches the temporary rectangle's own area,
;;;      delete the rectangle, and what remains is the outline.
;;;
;;; The view is zoomed to the temporary frame before BOUNDARY runs and restored
;;; afterwards. This is not cosmetic: BOUNDARY only traces what is within the
;;; current view, so anything off screen would be silently missed.
;;;
;;;   SHRINKWRAP  - outline a selection of objects
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; ShrinkWrap:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun ShrinkWrap:Doc nil
    (eval (list 'defun 'ShrinkWrap:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (ShrinkWrap:Doc)
)

;; ---------------------------------------------------------------------------
;; ShrinkWrap:BoundingBox
;; ---------------------------------------------------------------------------
;; Returns (lowerLeft upperRight) in WCS, enclosing every object in the
;; selection, or nil if no object could be measured.
;;
;; Each object's own bounding box is requested and the extremes of all of them
;; combined. Objects that cannot report a bounding box - and a few can not -
;; are skipped rather than aborting the whole measurement, which is why the
;; GetBoundingBox call is both tested for applicability and wrapped in a catch.
;; ---------------------------------------------------------------------------
(defun ShrinkWrap:BoundingBox ( sel / idx obj lo hi lows highs )
    (repeat (setq idx (sslength sel))
        (if (and (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                 (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p
                          (vl-catch-all-apply 'vla-getboundingbox (list obj 'lo 'hi))
                      )
                 )
            )
            (setq lows  (cons (vlax-safearray->list lo) lows)
                  highs (cons (vlax-safearray->list hi) highs)
            )
        )
    )
    ;; Take the minimum of every lower corner and the maximum of every upper
    ;; corner, ordinate by ordinate.
    (if (and lows highs)
        (mapcar (function (lambda ( fn pts ) (apply 'mapcar (cons fn pts))))
               '(min max)
                (list lows highs)
        )
    )
)

;; ---------------------------------------------------------------------------
;; ShrinkWrap:Outline
;; ---------------------------------------------------------------------------
;; Performs the outline operation. Returns a selection set of everything it
;; created, or nil if the selection could not be measured.
;;
;; sel - [pickset] the objects to outline
;; ---------------------------------------------------------------------------
(defun ShrinkWrap:Outline ( sel / app box margin corners frameArea frame
                                  echo marker result obj tmp )

    (if (setq box (ShrinkWrap:BoundingBox sel))
        (progn
            (setq app    (vlax-get-acad-object)
                  ;; Margin scaled to the size of the selection, so it works
                  ;; equally on a 10mm detail and a 500m site plan.
                  margin (/ (apply 'distance box) 20.0)
                  ;; The temporary frame corners: lower-left pushed out by the
                  ;; margin, upper-right pushed out by the same.
                  corners (mapcar (function (lambda ( pt op ) (mapcar op pt (list margin margin))))
                                  box
                                 '(- +)
                          )
                  ;; The frame's own area, needed later to identify and discard
                  ;; the boundary that merely retraces the frame itself.
                  frameArea (apply '* (apply 'mapcar (cons '- (reverse corners))))
                  margin    (* margin 1.5)
            )

            ;; Build the temporary rectangle. 070 bit 1 marks it closed.
            (setq frame
                (entmakex
                    (append
                       '(  (000 . "LWPOLYLINE")
                           (100 . "AcDbEntity")
                           (100 . "AcDbPolyline")
                           (090 . 4)
                           (070 . 1)
                        )
                        (mapcar
                            (function
                                (lambda ( accessors )
                                    (cons 10 (mapcar (function (lambda ( fn ) ((eval fn) corners)))
                                                     accessors
                                             )
                                    )
                                )
                            )
                           '(  (caar   cadar)
                               (caadr  cadar)
                               (caadr cadadr)
                               (caar  cadadr)
                            )
                        )
                    )
                )
            )

            ;; Zoom to the frame so BOUNDARY can see everything it must trace.
            (apply 'vlax-invoke
                (vl-list* app 'zoomwindow
                    (mapcar (function (lambda ( pt op ) (mapcar op pt (list margin margin 0.0))))
                            box
                           '(- +)
                    )
                )
            )

            ;; Remember the last object in the database, so that afterwards
            ;; everything created by BOUNDARY can be found by walking forward
            ;; from this marker.
            (setq echo   (getvar 'cmdecho)
                  marker (entlast)
                  result (ssadd)
            )
            (while (setq tmp (entnext marker)) (setq marker tmp))
            (setvar 'cmdecho 0)

            ;; The BOUNDARY switches, in order:
            ;;   _a _b _n sel frame ""  - advanced, boundary set, new, built
            ;;                            from the selection plus the frame
            ;;   _i _y                  - island detection on
            ;;   _o _p                  - object type: polyline
            ;;   ""                     - accept and move to seed point
            ;;   _non <point>           - seed point in the margin gap, with
            ;;                            snaps suppressed
            (command
                "_.-boundary" "_a" "_b" "_n" sel frame "" "_i" "_y" "_o" "_p" "" "_non"
                (trans (mapcar '- (car box) (list (/ margin 3.0) (/ margin 3.0))) 0 1)
                ""
            )
            ;; BOUNDARY can leave the command active; feed it Enters until done.
            (while (< 0 (getvar 'cmdactive)) (command ""))

            (entdel frame)

            ;; Walk everything created since the marker. Anything whose area
            ;; matches the temporary frame IS the frame's own trace, and is
            ;; discarded; everything else is genuine outline.
            (while (setq marker (entnext marker))
                (if (and (vlax-property-available-p
                             (setq obj (vlax-ename->vla-object marker)) 'area
                         )
                         (equal (vla-get-area obj) frameArea 1e-4)
                    )
                    (entdel marker)
                    (ssadd  marker result)
                )
            )

            (vla-zoomprevious app)
            (setvar 'cmdecho echo)
            result
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:SHRINKWRAP  -  main routine
;; ---------------------------------------------------------------------------
(defun c:SHRINKWRAP ( / *error* vars vals sel created idx )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun ShrinkWrap:Restore ( )
        ;; Close any command left open by an interrupted BOUNDARY before
        ;; attempting to end the undo group.
        (while (< 0 (getvar 'cmdactive)) (command ""))
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (ShrinkWrap:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** SHRINKWRAP error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (if (setq sel (ssget))
        (progn
            ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
            ;; unless the routine says up front that it will use one. Restore does,
            ;; to close this undo group. The declaring call is absent on older
            ;; releases, so it is wrapped rather than tested for.
            (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
            (command "_.UNDO" "_Begin")
            (setq created (ShrinkWrap:Outline sel))

            (if (and created (< 0 (sslength created)))
                (progn
                    (princ (strcat "\n" (itoa (sslength created))
                                   " outline" (if (= 1 (sslength created)) "" "s")
                                   " created."
                           )
                    )

                    ;; Offered rather than assumed - erasing the originals is
                    ;; destructive and the outline is often wanted alongside
                    ;; the geometry it was taken from.
                    (initget "Yes No")
                    (if (= "Yes" (getkword "\nErase the original objects? [Yes/No] <No>: "))
                        (progn
                            (repeat (setq idx (sslength sel))
                                (entdel (ssname sel (setq idx (1- idx))))
                            )
                            (princ (strcat "\n" (itoa (sslength sel)) " original objects erased."))
                        )
                    )
                )
                (princ "\nNo outline could be generated from that selection.")
            )
        )
        (princ "\nNothing selected.")
    )

    (ShrinkWrap:Restore)
    (princ)
)

(princ)