;;; ---------------------------------------------------------------------------
;;; DwgPush.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; COPY OBJECTS INTO OTHER DRAWINGS WITHOUT OPENING THEM
;;;
;;; Select objects, tick a list of drawing files, and DwgPush copies those
;;; objects into every one of them and saves them -- all without opening a
;;; single drawing in the editor.
;;;
;;; This is the job that otherwise means opening thirty drawings one at a
;;; time, pasting to the same coordinates in each, saving, and closing. On a
;;; revision that adds a new north arrow, a revised legend or an updated
;;; general note to a whole drawing set, that is an afternoon's work reduced
;;; to a few seconds.
;;;
;;; Objects land in the SAME layout name they were copied from. Copy from
;;; the Model tab and they arrive in Model space; copy from a layout called
;;; "A-101" and they arrive in the target's "A-101" layout, which is created
;;; if it does not exist. Coordinates are preserved exactly, so anything
;;; positioned relative to a title block stays where it belongs.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW IT WORKS
;;;
;;; The heavy lifting is done by ObjectDBX -- a database-only interface that
;;; opens a DWG file's contents in memory with no editor window, no regen,
;;; no view, and no plot settings to reconcile. It is dramatically faster
;;; than scripting the real editor, and it cannot disturb the drawing the
;;; user is currently working in.
;;;
;;; The sequence is:
;;;   1. Select the source objects (viewports are excluded -- they cannot be
;;;      meaningfully copied between drawings).
;;;   2. Choose target files through the multi-file browser below.
;;;   3. Pack the source objects into a safearray variant, which is the only
;;;      form vla-CopyObjects accepts.
;;;   4. For each target: get a document object, find or create the matching
;;;      layout, copy the objects into that layout's block, and save.
;;;
;;; Step 4 has an important subtlety. If a target drawing is ALREADY OPEN in
;;; this AutoCAD session, ObjectDBX must not be used on it -- two independent
;;; handles on one file will overwrite each other's changes. The program
;;; therefore builds an index of every open document up front and routes
;;; those files through the live document object instead.
;;;
;;; The currently active drawing is skipped altogether. Copying objects into
;;; the drawing you are copying them FROM would duplicate them, and the save
;;; that follows would commit that duplication without asking.
;;;
;;; ---------------------------------------------------------------------------
;;; CAVEATS
;;;
;;; Target files must not be open in another AutoCAD session or held
;;; read-only; those are reported as failures and skipped, and the count at
;;; the end tells you how many did not take.
;;;
;;; Saving is unconditional and there is no undo across files. Run it on a
;;; test copy first if the target set matters.
;;;
;;; ---------------------------------------------------------------------------
;;;   DWGPUSH - copy selected objects into other drawing files
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; DWGPUSH
;;; ---------------------------------------------------------------------------

(defun c:DwgPush

    ( / *error* DwgPush:GetLayout DwgPush:Restore
        acd app cnt dbx doc dwgs failed here idx msg objs opened sel tab
        vals vars vrs
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; DwgPush:Restore
    ;;;
    ;;; Releases the ObjectDBX interface object and puts system variables
    ;;; back. Releasing matters: an un-released ObjectDBX object keeps a
    ;;; COM handle on the last file it touched, which can leave that file
    ;;; locked until AutoCAD closes.
    ;;; -----------------------------------------------------------------------

    (defun DwgPush:Restore ( )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (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 )
        (DwgPush:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** DWGPUSH error: " msg " **"))
        )
        (princ)
    )

    ;;; -----------------------------------------------------------------------
    ;;; DwgPush:GetLayout
    ;;;
    ;;; Returns the block object of the named layout in the given document,
    ;;; creating the layout first if it is not there.
    ;;;
    ;;; Every layout owns a block; that block is the container the objects
    ;;; must be copied into. Model space is a layout too, named "Model", so
    ;;; the same code path serves both cases.
    ;;;
    ;;; vla-Item raises an error rather than returning nil when the item is
    ;;; missing, so the lookup is caught and a nil result treated as "not
    ;;; present, create it".
    ;;;
    ;;;   doc - document object (live or ObjectDBX)
    ;;;   nme - layout name
    ;;; -----------------------------------------------------------------------

    (defun DwgPush:GetLayout ( doc nme / lay )
        (setq lay (vl-catch-all-apply 'vla-item (list (vla-get-layouts doc) nme)))
        (vla-get-block
            (if (vl-catch-all-error-p lay)
                (vla-add (vla-get-layouts doc) nme)
                lay
            )
        )
    )

    ;;; =======================================================================
    ;;;                       M A I N   R O U T I N E
    ;;; =======================================================================

    (setvar 'cmdecho 0)
    ;; 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 app (vlax-get-acad-object)
          acd (vla-get-activedocument app)
          ;; CVPORT 1 means the paper space "sheet" is active rather than a
          ;; floating viewport, so CTAB names the layout being worked in.
          ;; Anything else means model space, whether tabbed or in a viewport.
          tab (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")
          cnt 0
    )
    (princ (strcat "\nCopying from layout: " tab))

    (cond
        ;;  ---- selection and file list --------------------------------------
        ;;  Viewports are excluded: a viewport is a window onto its own
        ;;  drawing's model space and is meaningless in another file. The 410
        ;;  filter restricts the selection to the current layout only.

        (   (not
                (and
                    (setq sel (ssget (list '(0 . "~VIEWPORT") (cons 410 tab))))
                    (setq dwgs (DwgPush:GetFiles "Select drawings to copy to" "" "dwg;dwt;dws"))
                )
            )
            (princ "\nCancelled - nothing selected, or no target drawings chosen.")
        )

        ;;  ---- ObjectDBX interface ------------------------------------------
        ;;  The ProgID is version-stamped from AutoCAD 2004 (version 16)
        ;;  onwards, so the major version number is read from ACADVER and
        ;;  appended. Older releases use the unversioned name.

        (   (progn
                (setq vrs (atoi (getvar 'acadver))
                      dbx (vl-catch-all-apply 'vla-getinterfaceobject
                              (list app
                                  (if (< vrs 16)
                                      "objectdbx.axdbdocument"
                                      (strcat "objectdbx.axdbdocument." (itoa vrs))
                                  )
                              )
                          )
                )
                (or (null dbx) (vl-catch-all-error-p dbx))
            )
            (princ "\nUnable to interface with ObjectDBX.")
        )

        (   t
            ;; ---- index every open document ----------------------------------
            ;; Keyed on the upper-cased full path so the later lookup is
            ;; case-insensitive, as Windows paths are.

            (vlax-for doc (vla-get-documents app)
                (setq opened (cons (cons (strcase (vla-get-fullname doc)) doc) opened))
            )
            (setq here (strcase (strcat (getvar 'dwgprefix) (getvar 'dwgname))))

            ;; ---- pack the selection into a variant ---------------------------
            ;; vla-CopyObjects will not take a LISP list; it needs a variant
            ;; wrapping a safearray of VLA objects. The array is built at the
            ;; exact required length, indexed from zero.

            (setq idx (sslength sel))
            (repeat idx
                (setq objs (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) objs))
            )
            (setq objs
                (vlax-make-variant
                    (vlax-safearray-fill
                        (vlax-make-safearray vlax-vbobject (cons 0 (1- (length objs))))
                        objs
                    )
                )
            )

            ;; ---- copy into each target ---------------------------------------

            (foreach dwg dwgs
                (cond
                    ;;  Never push into the drawing we are pushing from.
                    (   (= here (strcase dwg))
                        (princ "\nSkipped the current drawing - objects would be duplicated.")
                        (setq failed (cons dwg failed))
                    )

                    ;;  Already open in this session: use the live document so
                    ;;  the editor and this routine cannot fight over the file.
                    (   (setq doc (cdr (assoc (strcase dwg) opened)))
                        (vla-copyobjects acd objs (DwgPush:GetLayout doc tab))
                        (vla-saveas doc dwg)
                        (setq cnt (1+ cnt))
                    )

                    ;;  Not open: pull it in through ObjectDBX.
                    (   (not (vl-catch-all-error-p
                                 (vl-catch-all-apply 'vla-open (list dbx dwg))
                             )
                        )
                        (vla-copyobjects acd objs (DwgPush:GetLayout dbx tab))
                        (vla-saveas dbx dwg)
                        (setq cnt (1+ cnt))
                    )

                    ;;  Locked, missing, read-only, or not a valid drawing.
                    (   t
                        (princ (strcat "\nUnable to open: " (vl-filename-base dwg)
                                       (vl-filename-extension dwg)))
                        (setq failed (cons dwg failed))
                    )
                )
            )

            ;; ---- report -----------------------------------------------------

            (setq msg
                (if (< 0 cnt)
                    (strcat "\n" (itoa (sslength sel))
                            (if (= 1 (sslength sel)) " object" " objects")
                            " copied to " (itoa cnt)
                            (if (= 1 cnt) " drawing." " drawings.")
                    )
                    "\nNo drawings were updated."
                )
            )
            (if failed
                (setq msg
                    (strcat msg "\nUnable to copy to " (itoa (length failed))
                            (if (= 1 (length failed)) " drawing." " drawings.")
                    )
                )
            )
            (princ msg)
        )
    )

    (DwgPush:Restore)
    (princ)
)

;;; ===========================================================================
;;;              M U L T I - F I L E   S E L E C T I O N   D I A L O G
;;; ===========================================================================
;;;
;;; AutoCAD's built-in getfiled can only return one file. This is a full
;;; replacement that returns a list.
;;;
;;; The dialog is a two-pane browser: the left pane lists the contents of the
;;; current folder, the right pane holds the files chosen so far. Files move
;;; between them by double-clicking or by the Add / Remove buttons, and the
;;; folder is changed by typing a path, double-clicking a subfolder, ".." to
;;; go up, or the Browse button for a native folder picker.
;;;
;;; Because a DCL dialog cannot be built from a string in memory, the layout
;;; below is written to a uniquely-named temporary file, loaded, and deleted
;;; on exit. The unique name means two AutoCAD sessions running at once
;;; cannot clash over it.
;;;
;;;   msg - dialog title; "Select Files" if nil or ""
;;;   def - starting folder; the current drawing's folder if nil or ""
;;;   ext - semicolon-separated extension filter, e.g. "dwg;dwt"; "*" if nil
;;;
;;; Returns a list of full file paths, or nil if cancelled.
;;; ---------------------------------------------------------------------------

(defun DwgPush:GetFiles ( msg def ext / *error* dch dcl des dir dirdata lst rtn tmp )

    ;;  dirdata caches the contents of every folder visited during this one
    ;;  dialog session. Listing a network folder can take a noticeable moment,
    ;;  and the list is re-read every time a file is added or removed, so the
    ;;  cache is what keeps the dialog responsive.

    (defun *error* ( msg )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** File dialog error: " msg " **"))
        )
        (princ)
    )

    (if
        (and
            (setq dcl (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open dcl "w"))
            (progn
                ;; ---- DCL layout -----------------------------------------
                ;; "lst" and "but" are prototype tiles: defining the shared
                ;; sizing once and deriving both list boxes and both buttons
                ;; from it keeps the two columns identical in width and
                ;; height, which is what makes the dialog look symmetrical.
                (foreach line
                   '(
                        "lst : list_box"
                        "{"
                        "    width = 40.0;"
                        "    height = 20.0;"
                        "    fixed_width = true;"
                        "    fixed_height = true;"
                        "    alignment = centered;"
                        "    multiple_select = true;"
                        "}"
                        "but : button"
                        "{"
                        "    width = 20.0;"
                        "    height = 1.8;"
                        "    fixed_width = true;"
                        "    fixed_height = true;"
                        "    alignment = centered;"
                        "}"
                        "getfiles : dialog"
                        "{"
                        "    key = \"title\"; spacer;"
                        "    : row"
                        "    {"
                        "        alignment = centered;"
                        "        : edit_box { key = \"dir\"; label = \"Folder:\"; }"
                        "        : button"
                        "        {"
                        "            key = \"brw\";"
                        "            label = \"Browse\";"
                        "            fixed_width = true;"
                        "        }"
                        "    }"
                        "    spacer;"
                        "    : row"
                        "    {"
                        "        : column"
                        "        {"
                        "            : lst { key = \"box1\"; }"
                        "            : but { key = \"add\" ; label = \"Add Files\"; }"
                        "        }"
                        "        : column {"
                        "            : lst { key = \"box2\"; }"
                        "            : but { key = \"del\" ; label = \"Remove Files\"; }"
                        "        }"
                        "    }"
                        "    spacer; ok_cancel;"
                        "}"
                    )
                    (write-line line des)
                )
                (setq des (close des))
                (< 0 (setq dch (load_dialog dcl)))
            )
            (new_dialog "getfiles" dch)
        )
        (progn
            ;; ---- initial state --------------------------------------------
            (setq ext
                (if (= 'str (type ext))
                    (DwgPush:Split (strcase ext) ";")
                   '("*")
                )
            )
            (set_tile "title" (if (member msg '(nil "")) "Select Files" msg))
            (set_tile "dir"
                (setq dir
                    (DwgPush:FixDir
                        (if (or (member def '(nil ""))
                                (not (vl-file-directory-p (DwgPush:FixDir def))))
                            (getvar 'dwgprefix)
                            def
                        )
                    )
                )
            )
            (setq lst (DwgPush:ShowFiles dir ext nil))

            ;; Both action buttons start disabled; they enable only when the
            ;; matching list has a valid selection, so the user cannot press
            ;; Add with nothing chosen and wonder why nothing happened.
            (mode_tile "add" 1)
            (mode_tile "del" 1)

            ;;; ---------------------------------------------------------------
            ;;; Action expressions.
            ;;;
            ;;; DCL callbacks are strings evaluated later, in the scope of
            ;;; this function. Writing them as quoted lists and converting
            ;;; with vl-prin1-to-string is far safer than hand-escaping a
            ;;; string full of quotes -- the printer produces correct syntax
            ;;; every time.
            ;;;
            ;;; $value is the tile's current value, $reason is why the
            ;;; callback fired: 1 = value changed and focus left,
            ;;; 4 = double-click.
            ;;; ---------------------------------------------------------------

            ;;  Browse button: native folder picker.
            (action_tile "brw"
                (vl-prin1-to-string
                   '(if (setq tmp (DwgPush:BrowseFolder "" nil 512))
                        (setq lst (DwgPush:ShowFiles (set_tile "dir" (setq dir tmp)) ext rtn)
                              rtn (DwgPush:ShowChosen dir rtn)
                        )
                    )
                )
            )

            ;;  Folder edit box: retype a path directly.
            (action_tile "dir"
                (vl-prin1-to-string
                   '(if (= 1 $reason)
                        (setq lst (DwgPush:ShowFiles
                                      (set_tile "dir" (setq dir (DwgPush:FixDir $value)))
                                      ext rtn
                                  )
                              rtn (DwgPush:ShowChosen dir rtn)
                        )
                    )
                )
            )

            ;;  Left list: single click updates the Add button; double-click
            ;;  either navigates into a folder or adds the files.
            (action_tile "box1"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm tmp )
                            ;; $value is a space-separated list of indices;
                            ;; wrapping it in brackets and reading it turns it
                            ;; into a LISP list in one step.
                            (if (setq itm (mapcar '(lambda ( n ) (nth n lst))
                                                  (read (strcat "(" $value ")"))
                                          )
                                )
                                (if (= 4 $reason)
                                    (cond
                                        ;;  ".." - go up one level.
                                        (   (equal '("..") itm)
                                            (setq lst (DwgPush:ShowFiles
                                                          (set_tile "dir" (setq dir (DwgPush:UpDir dir)))
                                                          ext rtn
                                                      )
                                                  rtn (DwgPush:ShowChosen dir rtn)
                                            )
                                        )
                                        ;;  A folder - descend into it.
                                        (   (vl-file-directory-p
                                                (setq tmp (DwgPush:Redirect (strcat dir "\\" (car itm))))
                                            )
                                            (setq lst (DwgPush:ShowFiles
                                                          (set_tile "dir" (setq dir tmp)) ext rtn
                                                      )
                                                  rtn (DwgPush:ShowChosen dir rtn)
                                            )
                                        )
                                        ;;  Files - add them to the chosen list.
                                        (   (setq rtn (DwgPush:Sort
                                                          (append rtn
                                                              (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)
                                                          )
                                                      )
                                                  rtn (DwgPush:ShowChosen dir rtn)
                                                  lst (DwgPush:ShowFiles dir ext rtn)
                                            )
                                        )
                                    )
                                    ;;  Single click: Add is useful only if at
                                    ;;  least one non-folder is highlighted.
                                    (if (vl-every '(lambda ( x ) (vl-file-directory-p (strcat dir "\\" x))) itm)
                                        (mode_tile "add" 1)
                                        (mode_tile "add" 0)
                                    )
                                )
                            )
                        )
                    )
                )
            )

            ;;  Right list: double-click removes an entry.
            (action_tile "box2"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (mapcar '(lambda ( n ) (nth n rtn))
                                                  (read (strcat "(" $value ")"))
                                          )
                                )
                                (if (= 4 $reason)
                                    (setq rtn (DwgPush:ShowChosen dir (vl-remove (car itm) rtn))
                                          lst (DwgPush:ShowFiles dir ext rtn)
                                    )
                                    (mode_tile "del" 0)
                                )
                            )
                        )
                    )
                )
            )

            ;;  Add button: move every highlighted file across, ignoring any
            ;;  folders caught in the same drag-selection.
            (action_tile "add"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm
                                    (vl-remove-if 'vl-file-directory-p
                                        (mapcar '(lambda ( n ) (nth n lst))
                                                (read (strcat "(" (get_tile "box1") ")"))
                                        )
                                    )
                                )
                                (setq rtn (DwgPush:Sort
                                              (append rtn
                                                  (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)
                                              )
                                          )
                                      rtn (DwgPush:ShowChosen dir rtn)
                                      lst (DwgPush:ShowFiles dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )

            ;;  Remove button: drop every highlighted entry from the chosen list.
            (action_tile "del"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (read (strcat "(" (get_tile "box2") ")")))
                                (setq rtn (DwgPush:ShowChosen dir (DwgPush:RemoveNth itm rtn))
                                      lst (DwgPush:ShowFiles dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )

            ;; start_dialog returns 0 for Cancel, 1 for OK.
            (if (zerop (start_dialog))
                (setq rtn nil)
            )
        )
    )
    (*error* nil)
    rtn
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:FillList
;;;
;;; Replaces the contents of a list box tile and returns the list, so the
;;; caller can capture what is now displayed in the same expression that
;;; displays it.
;;; ---------------------------------------------------------------------------

(defun DwgPush:FillList ( key lst )
    (start_list key)
    (foreach x lst (add_list x))
    (end_list)
    lst
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:ListFolder
;;;
;;; Returns the displayable contents of a folder: subfolders first in sorted
;;; order, then files matching the extension filter, with anything already
;;; chosen filtered out so it cannot be added twice.
;;;
;;; Results are cached in dirdata, which belongs to the calling dialog
;;; function. Revisiting a folder is then instantaneous.
;;;
;;;   dir - folder path, no trailing backslash
;;;   ext - list of upper-case extension patterns, or ("*")
;;;   lst - full paths already chosen, to be excluded
;;; ---------------------------------------------------------------------------

(defun DwgPush:ListFolder ( dir ext lst )
    (vl-remove-if '(lambda ( x ) (member (strcat dir "\\" x) lst))
        (cond
            ;;  Already cached.
            (   (cdr (assoc dir dirdata)))
            ;;  First visit: build the listing and cache it.
            (   (cdar
                    (setq dirdata
                        (cons
                            (cons dir
                                (append
                                    ;;  Subfolders. "." is removed as
                                    ;;  meaningless; ".." is kept because it is
                                    ;;  how the user navigates upwards.
                                    (DwgPush:SortNatural
                                        (vl-remove "." (vl-directory-files dir nil -1))
                                    )
                                    ;;  Files, filtered by extension.
                                    (DwgPush:Sort
                                        (if (member ext '(("") ("*")))
                                            (vl-directory-files dir nil 1)
                                            (vl-remove-if-not
                                               '(lambda ( x / e )
                                                    (and (setq e (vl-filename-extension x))
                                                         (setq e (strcase (substr e 2)))
                                                         (vl-some '(lambda ( w ) (wcmatch e w)) ext)
                                                    )
                                                )
                                                (vl-directory-files dir nil 1)
                                            )
                                        )
                                    )
                                )
                            )
                            dirdata
                        )
                    )
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:Redirect
;;;
;;; Resolves the legacy junction folders Windows keeps under the user
;;; profile. "My Documents", "My Pictures" and friends still appear in
;;; directory listings but are junction points that cannot be listed
;;; directly; the real folder has the shorter modern name.
;;;
;;; Without this, double-clicking "My Documents" in the dialog would open an
;;; empty folder.
;;;
;;; Returns the real path, or the input unchanged if no redirect applies.
;;; ---------------------------------------------------------------------------

(defun DwgPush:Redirect ( dir / itm pos )
    (cond
        ;;  It lists fine, so it is a real folder.
        (   (vl-directory-files dir) dir)
        ;;  It is directly under the user profile and has a known modern name.
        (   (and
                (= (strcase (getenv "UserProfile"))
                   (strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t))))
                )
                (setq itm
                    (cdr
                        (assoc (substr (strcase dir t) (+ pos 2))
                           '(
                                ("my documents" . "Documents")
                                ("my pictures"  . "Pictures")
                                ("my videos"    . "Videos")
                                ("my music"     . "Music")
                            )
                        )
                    )
                )
                (vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
            )
            itm
        )
        (   dir)
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:Sort
;;;
;;; Sorts a file list the way a file browser does: grouped by extension, and
;;; naturally ordered within each group.
;;;
;;; Files are grouped by extension, the groups are ordered alphabetically by
;;; extension, each group is sorted naturally, and the groups are then
;;; concatenated.
;;; ---------------------------------------------------------------------------

(defun DwgPush:Sort ( lst )
    (apply 'append
        (mapcar 'DwgPush:SortNatural
            (vl-sort
                (DwgPush:GroupBy lst
                   '(lambda ( a b / x y )
                        (and (setq x (vl-filename-extension a))
                             (setq y (vl-filename-extension b))
                             (= (strcase x) (strcase y))
                        )
                    )
                )
               '(lambda ( a b / x y )
                    (and (setq x (vl-filename-extension (car a)))
                         (setq y (vl-filename-extension (car b)))
                         (< (strcase x) (strcase y))
                    )
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:SortNatural
;;;
;;; Sorts strings so that embedded numbers compare as numbers.
;;;
;;; A plain alphabetic sort produces the familiar annoyance:
;;;     Sheet1, Sheet10, Sheet11, Sheet2
;;; whereas this produces what anyone actually wants:
;;;     Sheet1, Sheet2, Sheet10, Sheet11
;;;
;;; Each name is first split into alternating text and numeric pieces by
;;; DwgPush:SplitName. Comparison then walks both piece-lists in step,
;;; skipping equal pieces, and decides on the first difference: numbers
;;; compare numerically, text compares alphabetically, and a number sorts
;;; before text so "Sheet2" precedes "SheetA".
;;;
;;; vl-sort-i returns an index order rather than the sorted values, which is
;;; what allows the original strings to be reordered by the comparison of
;;; their split forms.
;;; ---------------------------------------------------------------------------

(defun DwgPush:SortNatural ( lst )
    (mapcar '(lambda ( n ) (nth n lst))
        (vl-sort-i (mapcar 'DwgPush:SplitName lst)
           '(lambda ( a b / x y )
                (while (and (setq x (car a)) (setq y (car b)) (= x y))
                    (setq a (cdr a)
                          b (cdr b)
                    )
                )
                (cond
                    (   (null x) b)                            ;; a ran out first: a is shorter
                    (   (null y) nil)                          ;; b ran out first: b is shorter
                    (   (and (numberp x) (numberp y)) (< x y)) ;; both numeric
                    (   (numberp x))                           ;; numbers before text
                    (   (numberp y) nil)
                    (   (< x y))                               ;; both text
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:GroupBy
;;;
;;; Partitions a list into sublists of items that the supplied predicate
;;; considers equivalent. Order within each group is preserved.
;;;
;;; It works by taking the first item, sweeping the rest into "matches" and
;;; "leftovers", emitting the matches as one group, and recursing on the
;;; leftovers.
;;;
;;;   lst - list to group
;;;   fun - predicate taking two items, returning non-nil if they belong together
;;; ---------------------------------------------------------------------------

(defun DwgPush:GroupBy ( lst fun / first match rest )
    (if (setq first (car lst))
        (progn
            (foreach item (cdr lst)
                (if (fun first item)
                    (setq match (cons item match))
                    (setq rest  (cons item rest))
                )
            )
            (cons (cons first (reverse match))
                  (DwgPush:GroupBy (reverse rest) fun)
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:SplitName
;;;
;;; Splits a string into a LISP list of alternating text and numeric pieces,
;;; for the natural sort above. "Sheet10a" becomes ("S" "H" ... 10 "A").
;;;
;;; The string is processed one character at a time:
;;;   * hyphen, full stop and backslash become separators, so path and
;;;     extension boundaries break the runs;
;;;   * digits are emitted bare, so consecutive digits fuse into one number
;;;     when the result is read back;
;;;   * anything else is emitted wrapped in quotes as a one-character string.
;;;
;;; The assembled character codes are turned into a string and handed to
;;; read, which does the actual parsing into numbers and strings. Building a
;;; source string and reading it is far faster in AutoLISP than assembling
;;; the list by hand.
;;; ---------------------------------------------------------------------------

(defun DwgPush:SplitName ( str )
    (   (lambda ( chars )
            (read
                (strcat "("
                    (vl-list->string
                        (apply 'append
                            (mapcar
                               '(lambda ( prev this next )
                                    (cond
                                        (   (member this '(45 46 92)) (list 32))          ;; - . \  become spaces
                                        (   (< 47 this 58)            (list this))        ;; digits pass through
                                        (   (list 32 34 this 34 32))                      ;; else " x "
                                    )
                                )
                                ;; Three parallel lists give each character its
                                ;; neighbours, which mapcar needs to run in step.
                                (cons nil chars) chars (append (cdr chars) '(()))
                            )
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list (strcase str))
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:BrowseFolder
;;;
;;; Opens the native Windows folder picker through the Shell COM object and
;;; returns the chosen path, or nil.
;;;
;;; Three COM objects are created and every one must be released explicitly:
;;; an unreleased Shell object survives the command and leaks for the rest of
;;; the session. The releases are outside the catch so that they happen even
;;; when the picker itself fails.
;;;
;;;   msg - prompt shown in the picker
;;;   dir - starting folder, or nil
;;;   flg - Shell BROWSEINFO flags; 512 suppresses the "New Folder" button
;;; ---------------------------------------------------------------------------

(defun DwgPush:BrowseFolder ( msg dir flg / err fld pth shl slf )
    (setq err
        (vl-catch-all-apply
           '(lambda ( / app hwd )
                (if (setq app (vlax-get-acad-object)
                          shl (vla-getinterfaceobject app "shell.application")
                          hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
                          fld (vlax-invoke-method shl 'browseforfolder
                                  (if (vl-catch-all-error-p hwd) 0 hwd) msg flg dir
                              )
                    )
                    ;; The returned Folder object does not expose a path
                    ;; directly; its Self property is the FolderItem that does.
                    (setq slf (vlax-get-property fld 'self)
                          pth (DwgPush:FixDir (vlax-get-property slf 'path))
                    )
                )
            )
        )
    )
    (if slf (vlax-release-object slf))
    (if fld (vlax-release-object fld))
    (if shl (vlax-release-object shl))
    (if (vl-catch-all-error-p err)
        (princ (vl-catch-all-error-message err))
        pth
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:Relative
;;;
;;; Converts a full path to one relative to the given folder, purely so the
;;; chosen-files list stays readable. Showing thirty identical long paths
;;; would hide the only part that differs -- the file name.
;;;
;;; Rules, in the order tested:
;;;   * different drive letters       - no relative form exists, keep it full
;;;   * shared leading folder         - strip it and recurse
;;;   * path sits directly in dir     - ".\name"
;;;   * dir exhausted                 - what is left is the answer
;;;   * otherwise                     - step up a level with "..\" and recurse
;;; ---------------------------------------------------------------------------

(defun DwgPush:Relative ( dir path / p q )
    (setq dir (vl-string-right-trim "\\" dir))
    (cond
        (   (and (setq p (vl-string-position 58 dir))     ;; 58 = colon
                 (setq q (vl-string-position 58 path))
                 (/= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            path
        )
        (   (and (setq p (vl-string-position 92 dir))     ;; 92 = backslash
                 (setq q (vl-string-position 92 path))
                 (= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            (DwgPush:Relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
        )
        (   (and (setq q (vl-string-position 92 path))
                 (= (strcase dir) (strcase (substr path 1 q)))
            )
            (strcat ".\\" (substr path (+ 2 q)))
        )
        (   (= "" dir) path)
        (   (setq p (vl-string-position 92 dir))
            (DwgPush:Relative (substr dir (+ 2 p)) (strcat "..\\" path))
        )
        (   (DwgPush:Relative "" (strcat "..\\" path)))
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:Split
;;;
;;; Splits a delimited string into a list of substrings. Used to turn an
;;; extension filter such as "dwg;dwt;dws" into ("DWG" "DWT" "DWS").
;;; ---------------------------------------------------------------------------

(defun DwgPush:Split ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos)
              (DwgPush:Split (substr str (+ pos 1 (strlen del))) del)
        )
        (list str)
    )
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:ShowFiles / DwgPush:ShowChosen
;;;
;;; Refresh the two list boxes. They are separate one-line functions because
;;; the action expressions call them constantly and the pairing of list box
;;; key to content type should live in exactly one place.
;;;
;;; ShowChosen displays shortened relative paths but returns the untouched
;;; full paths, so the display never corrupts the data.
;;; ---------------------------------------------------------------------------

(defun DwgPush:ShowFiles ( dir ext lst )
    (DwgPush:FillList "box1" (DwgPush:ListFolder dir ext lst))
)

(defun DwgPush:ShowChosen ( dir lst )
    (DwgPush:FillList "box2"
        (mapcar '(lambda ( x ) (DwgPush:Relative dir x)) lst)
    )
    lst
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:UpDir
;;;
;;; Returns the parent of a folder path by truncating at the last backslash.
;;; ---------------------------------------------------------------------------

(defun DwgPush:UpDir ( dir )
    (substr dir 1 (vl-string-position 92 dir nil t))
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:FixDir
;;;
;;; Normalises a folder path: forward slashes become backslashes and any
;;; trailing backslash is removed, so paths can be concatenated without
;;; producing doubled separators.
;;; ---------------------------------------------------------------------------

(defun DwgPush:FixDir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

;;; ---------------------------------------------------------------------------
;;; DwgPush:RemoveNth
;;;
;;; Removes items from a list by position rather than by value, which is what
;;; the list box gives us. Removing by value would delete every duplicate,
;;; not the one the user actually highlighted.
;;;
;;;   idxs - list of zero-based indices to drop
;;;   lst  - list to filter
;;; ---------------------------------------------------------------------------

(defun DwgPush:RemoveNth ( idxs lst / n )
    (setq n -1)
    (vl-remove-if '(lambda ( x ) (member (setq n (1+ n)) idxs)) lst)
)

(princ "\nDwgPush loaded. Type DWGPUSH to copy objects into other drawings.")
(princ)

;;; ---------------------------------------------------------------------------
;;; End of file
;;; ---------------------------------------------------------------------------