;;; ---------------------------------------------------------------------------
;;; LayerHarvest.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; EXTRACT LAYER DATA FROM A WHOLE FOLDER OF DRAWINGS
;;;
;;; Points at a folder, reads every drawing in it, and writes out the
;;; complete layer table of each one: name, colour, linetype, lineweight,
;;; plot flag, plot style, on, locked, frozen, frozen in new viewports, and
;;; description.
;;;
;;; No drawing is opened in the editor. A hundred files are read in the time
;;; it takes to open one.
;;;
;;; This is the tool for auditing a drawing set against a layer standard. Run
;;; it, open the result in Excel, sort by layer name, and every drawing that
;;; has strayed shows up immediately -- the wrong colour on a dimension
;;; layer, a locked layer somebody forgot, a stray layer named "Layer1".
;;;
;;; ---------------------------------------------------------------------------
;;; OUTPUT FORMATS
;;;
;;; The format is chosen by the extension you give the output file:
;;;
;;;   .TXT  a fixed-width report, with columns padded to line up. The padding
;;;         character is selectable -- spaces for reading on screen, tabs or
;;;         commas for pasting elsewhere.
;;;
;;;   .CSV  opens directly in Excel. The separator comes from your own
;;;         Windows regional settings, so it imports cleanly in every locale
;;;         rather than only where the comma is the list separator.
;;;
;;;   .XML  either as structured XML, optionally with a stylesheet that makes
;;;         it a formatted, colour-banded table in a web browser; or as a
;;;         SpreadsheetML workbook, which Excel opens with one worksheet per
;;;         drawing.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW IT WORKS
;;;
;;; Drawings are read through ObjectDBX -- a database-only interface that
;;; loads a DWG file's contents into memory with no editor window, no regen
;;; and no view to set up.
;;;
;;; Any drawing that is already open in this AutoCAD session is read through
;;; its live document object instead. Using ObjectDBX on a file that is
;;; already open would read the version on disk, not the one on screen, and
;;; silently report stale data.
;;;
;;; Which fields are extracted is a bit field: each column has its own bit,
;;; and the check boxes set or clear it. The extraction walks the same
;;; ordered list of accessor functions each time and keeps only the ones
;;; whose bit is set, so adding a column means adding one accessor and one
;;; check box -- nothing else changes.
;;;
;;; ---------------------------------------------------------------------------
;;; NOTES
;;;
;;; Xref-dependent layers -- the ones with a vertical bar in their names --
;;; are excluded unless you tick the box. They belong to the referenced
;;; drawing, not this one, and would otherwise be reported twice.
;;;
;;; True colours are reported as "R,G,B"; ACI colours as a plain number.
;;;
;;; All settings, including the last folder and output choices, are
;;; remembered between sessions.
;;;
;;; ---------------------------------------------------------------------------
;;;   LAYERHARVEST - extract layer data from a folder of drawings
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; Column headings, in order. Their positions correspond to the bit values
;;; 1, 2, 4, 8 ... 1024, which is what the check boxes set.
;;; ---------------------------------------------------------------------------

(setq *LayerHarvest:Titles*
   '("Layer" "Colour" "Linetype" "Lineweight" "Plot" "PlotStyle"
     "On" "Locked" "Frozen" "Frozen VP" "Description")
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest: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 LayerHarvest:FixDir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:SavePath
;;;
;;; Where the settings file lives.
;;;
;;; The AutoCAD Support folder is preferred: per-user, roams with the
;;; profile, never cleaned out. Falling back through the folder holding
;;; acad.pat to AutoCAD's temporary folder means the chain always succeeds,
;;; so nothing has to treat "nowhere to write" as a failure.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:SavePath ( / dir )
    (cond
        (   (and (setq dir (getvar 'roamablerootprefix))
                 (vl-file-directory-p (strcat (LayerHarvest:FixDir dir) "\\Support"))
            )
            (strcat (LayerHarvest:FixDir dir) "\\Support")
        )
        (   (setq dir (findfile "acad.pat"))
            (LayerHarvest:FixDir (vl-filename-directory dir))
        )
        (   (LayerHarvest:FixDir (getvar 'tempprefix)))
    )
)

;;; ---------------------------------------------------------------------------
;;; LAYERHARVEST
;;; ---------------------------------------------------------------------------

(defun c:LayerHarvest

    ( /
        *error* LayerHarvest:Restore LayerHarvest:FillList
        LayerHarvest:FolderMode LayerHarvest:ShowPath LayerHarvest:XmlOptions

        acapp acdoc cfg data dbx dch dcl des doc dwgs ext heads odbx
        out result sfile syms tiles tmp vals values vars

        LH:Bits LH:Cur LH:Dir LH:Excel LH:Pad LH:Sub LH:Xref LH:Xsl
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; LayerHarvest:Restore
    ;;;
    ;;; Closes any open file, releases the ObjectDBX interface, unloads the
    ;;; dialog and deletes its temporary definition file.
    ;;;
    ;;; Releasing ObjectDBX matters: an unreleased interface object keeps a
    ;;; COM handle on the last file it touched, which can leave that file
    ;;; locked until AutoCAD closes.
    ;;; -----------------------------------------------------------------------

    (defun LayerHarvest:Restore ( )
        (foreach f (list des sfile)
            (if (= 'file (type f)) (close f))
        )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; LayerHarvest:FillList
    ;;;
    ;;; Loads a popup list tile with the supplied strings.
    ;;; -----------------------------------------------------------------------

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

    ;;; -----------------------------------------------------------------------
    ;;; LayerHarvest:FolderMode
    ;;;
    ;;; Greys out the folder controls when "current drawing only" is ticked,
    ;;; so it is obvious the folder is not being used.
    ;;; -----------------------------------------------------------------------

    (defun LayerHarvest:FolderMode ( val )
        (foreach key '("sub_dir" "dir" "dir_text") (mode_tile key (atoi val)))
        val
    )

    ;;; -----------------------------------------------------------------------
    ;;; LayerHarvest:ShowPath
    ;;;
    ;;; Displays a path in a text tile, shortened with an ellipsis if it is
    ;;; too long. Without this a deep network path runs off the edge of the
    ;;; dialog and the useful end of it is invisible.
    ;;; -----------------------------------------------------------------------

    (defun LayerHarvest:ShowPath ( key str )
        (set_tile key
            (cond
                (   (null str) "")
                (   (< 50 (strlen str)) (strcat (substr str 1 47) "..."))
                (   str)
            )
        )
    )

    ;;; -----------------------------------------------------------------------
    ;;; LayerHarvest:XmlOptions
    ;;;
    ;;; The secondary dialog offering the two XML flavours.
    ;;;
    ;;; They are mutually exclusive but implemented as toggles rather than
    ;;; radio buttons so that BOTH can be off, which produces plain XML with
    ;;; no stylesheet. Each toggle therefore clears the other.
    ;;; -----------------------------------------------------------------------

    (defun LayerHarvest:XmlOptions ( handle / xl xsl )
        (if (not (new_dialog "xml" handle))
            (princ "\nUnable to open the XML options dialog.")
            (progn
                (set_tile "xl"  (setq xl  LH:Excel))
                (set_tile "xsl" (setq xsl LH:Xsl))
                (action_tile "xl"  "(setq xl  $value xsl (set_tile \"xsl\" \"0\"))")
                (action_tile "xsl" "(setq xsl $value xl  (set_tile \"xl\"  \"0\"))")
                (if (= 1 (start_dialog))
                    (setq LH:Excel xl
                          LH:Xsl   xsl
                    )
                )
            )
        )
        (princ)
    )

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

    (setvar 'cmdecho 0)

    (setq acapp (vlax-get-acad-object)
          acdoc (vla-get-activedocument acapp)
          cfg   (strcat (LayerHarvest:SavePath) "\\YZ_LayerHarvest.cfg")
    )

    ;; 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 acapp)
        (setq odbx (cons (cons (strcase (vla-get-fullname doc)) doc) odbx))
    )

    ;; ---- settings ----------------------------------------------------------
    ;; LH:Bits defaults to 2047, which is all eleven columns switched on.

    (setq syms   '(LH:Dir LH:Cur LH:Sub LH:Bits LH:Xref LH:Pad LH:Excel LH:Xsl)
          values  (list (LayerHarvest:FixDir (getvar 'dwgprefix))
                        "0" "0" 2047 "0" "0" "0" "1")
    )
    (if (not (findfile cfg))
        (LayerHarvest:WriteConfig cfg values)
    )
    (LayerHarvest:ReadConfig cfg syms)
    ;; Anything the settings file did not supply falls back to its default.
    (mapcar '(lambda ( sym val ) (or (boundp sym) (set sym val))) syms values)

    ;; ---- build the dialog ---------------------------------------------------
    ;; Written to a uniquely named temporary file, loaded, and deleted on
    ;; exit, so two AutoCAD sessions cannot collide and nothing is left behind.

    (cond
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line
                           '(
                                "boxcol : boxed_column { width = 65.0; fixed_width  = true; alignment = centered; }"
                                "butt12 : button       { width = 12.0; fixed_width  = true; alignment = centered; }"
                                "space1 : spacer       { height = 0.1; fixed_height = true; }"
                                "pop    : popup_list   { width = 13.6; fixed_width  = true; alignment = centered; }"
                                ""
                                "layerextract : dialog { label = \"Layer Harvest\"; spacer;"
                                "  : boxcol { label = \"Fields to Extract\";"
                                "    spacer;"
                                "    : row { alignment = centered; spacer;"
                                "      : column {"
                                "        : toggle { key = \"layer\";      label = \"Layer\"; value = \"1\"; is_enabled = false; }"
                                "        : toggle { key = \"colour\";     label = \"Colour\"; }"
                                "        : toggle { key = \"linetype\";   label = \"Linetype\"; }"
                                "      }"
                                "      : column {"
                                "        : toggle { key = \"lineweight\"; label = \"Lineweight\"; }"
                                "        : toggle { key = \"plot\";       label = \"Plot\"; }"
                                "        : toggle { key = \"plotstyle\";  label = \"Plot Style\"; }"
                                "      }"
                                "      : column {"
                                "        : toggle { key = \"on\";         label = \"On\"; }"
                                "        : toggle { key = \"locked\";     label = \"Locked\"; }"
                                "        : toggle { key = \"frozen\";     label = \"Frozen\"; }"
                                "      }"
                                "      : column {"
                                "        : toggle { key = \"frozenvp\";    label = \"Frozen in VP\"; }"
                                "        : toggle { key = \"description\"; label = \"Description\"; }"
                                "        : spacer { height = 1.5; fixed_height = true; }"
                                "      }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : boxcol { label = \"Drawing Folder\";"
                                "    : row {"
                                "      : column { space1; : text { key = \"dir_text\"; alignment = left; } space1; }"
                                "      : butt12 { label = \"Browse...\"; key = \"dir\"; }"
                                "    }"
                                "    : row {"
                                "      : toggle { key = \"sub_dir\"; label = \"Include sub-folders\"; }"
                                "      : toggle { key = \"cur_dwg\"; label = \"Current drawing only\"; }"
                                "    }"
                                "    spacer;"
                                "  }"
                                "  spacer;"
                                "  : boxcol { label = \"Output\";"
                                "    : row {"
                                "      : column { space1; : text { key = \"out_text\"; alignment = left; } space1; }"
                                "      : butt12 { label = \"Browse...\"; key = \"browse\"; }"
                                "    }"
                                "    : row {"
                                "      : column { space1;"
                                "        : toggle { key = \"xref\"; label = \"Include xref layers\"; alignment = left; }"
                                "        space1; }"
                                "      : column { space1;"
                                "        : text { key = \"pad_text\"; label = \"Padding character:\"; alignment = right; }"
                                "        space1; }"
                                "      : column { : pop { key = \"pad\"; } space1; }"
                                "    }"
                                "  }"
                                "  spacer;"
                                "  : row { spacer;"
                                "    : butt12 { key = \"xml\"; label = \"XML...\"; }"
                                "    : spacer { width = 3.06; fixed_width = true;"
                                "               height = 2.06; fixed_height = true; }"
                                "    ok_cancel;"
                                "  }"
                                "}"
                                ""
                                "xml : dialog { label = \"XML Options\"; spacer;"
                                "  : row { spacer_1;"
                                "    : column {"
                                "      : toggle { key = \"xl\";  label = \"Excel compatible workbook\"; }"
                                "      : toggle { key = \"xsl\"; label = \"Create XSL stylesheet\"; }"
                                "    }"
                                "  }"
                                "  spacer; ok_cancel;"
                                "}"
                            )
                            (write-line line des)
                        )
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                    (new_dialog "layerextract" dch)
                )
            )
            (princ "\nUnable to create the dialog.")
        )

        (   t
            ;; The field check boxes, in bit order. "layer" is absent because
            ;; it is always extracted and its tile is disabled.
            (setq tiles
               '("colour" "linetype" "lineweight" "plot" "plotstyle"
                 "on" "locked" "frozen" "frozenvp" "description")
            )

            (LayerHarvest:ShowPath "dir_text" LH:Dir)
            (set_tile "sub_dir" LH:Sub)
            (LayerHarvest:FolderMode (set_tile "cur_dwg" LH:Cur))
            (set_tile "out_text" "Browse to select an output file")
            (set_tile "xref" LH:Xref)

            (LayerHarvest:FillList "pad"
               '("Space [   ]" "Tab [       ]" "Point [ . ]"
                 "Hyphen [ - ]" "Comma [ , ]" "Semi-Colon [ ; ]")
            )
            (set_tile "pad" LH:Pad)

            ;; Padding and XML options only apply to their own formats, so
            ;; both start greyed out and are enabled when the output file
            ;; extension calls for them.
            (foreach key '("pad" "pad_text") (mode_tile key 1))
            (mode_tile "xml" 1)

            ;; ---- set the field check boxes from the bit field --------------
            ;; The counter doubles on each pass, so tile N is tested against
            ;; bit 2^(N+1) -- bit 1 belongs to the always-on Layer column.
            (   (lambda ( bit )
                    (foreach tile tiles
                        (set_tile tile
                            (if (= (setq bit (lsh bit 1)) (logand LH:Bits bit)) "1" "0")
                        )
                    )
                )
                1
            )

            ;; ---- callbacks --------------------------------------------------
            ;; Written as quoted lists and converted with vl-prin1-to-string,
            ;; which produces correct quoting every time where hand-escaped
            ;; strings do not.

            (action_tile "dir"
                (vl-prin1-to-string
                   '(if (setq tmp (LayerHarvest:PickFolder
                                      "Select the folder of drawings to process..." nil 320))
                        (LayerHarvest:ShowPath "dir_text" (setq LH:Dir tmp))
                    )
                )
            )
            (action_tile "sub_dir" "(setq LH:Sub $value)")
            (action_tile "cur_dwg" "(LayerHarvest:FolderMode (setq LH:Cur $value))")

            ;; Choosing the output file also decides the format, so the
            ;; format-specific controls are enabled or greyed here.
            (action_tile "browse"
                (vl-prin1-to-string
                   '(progn
                        (if (setq tmp (getfiled "Create output file" "" "txt;csv;xml" 1))
                            (LayerHarvest:ShowPath "out_text" (setq out tmp))
                            (if out
                                (LayerHarvest:ShowPath "out_text" out)
                                (set_tile "out_text" "Browse to select an output file")
                            )
                        )
                        (if out
                            (cond
                                (   (= ".TXT" (setq ext (strcase (vl-filename-extension out))))
                                    (foreach key '("pad" "pad_text") (mode_tile key 0))
                                    (mode_tile "xml" 1)
                                )
                                (   (= ".XML" ext)
                                    (foreach key '("pad" "pad_text") (mode_tile key 1))
                                    (mode_tile "xml" 0)
                                )
                                (   t
                                    (foreach key '("pad" "pad_text") (mode_tile key 1))
                                    (mode_tile "xml" 1)
                                )
                            )
                        )
                    )
                )
            )

            (action_tile "xref" "(setq LH:Xref $value)")
            (action_tile "pad"  "(setq LH:Pad  $value)")
            (action_tile "xml"  "(LayerHarvest:XmlOptions dch)")

            ;; Each field check box sets or clears its own bit. The bit value
            ;; is baked into the callback string as a literal, so the counter
            ;; is evaluated now rather than when the callback fires.
            (   (lambda ( bit )
                    (foreach tile tiles
                        (action_tile tile
                            (strcat "(setq LH:Bits ((if (= \"1\" $value) + -) LH:Bits "
                                    (itoa (setq bit (lsh bit 1))) "))")
                        )
                    )
                )
                1
            )

            ;; OK: validated here so a mistake can be corrected without
            ;; losing everything else that was set.
            (action_tile "accept"
                (vl-prin1-to-string
                   '(cond
                        (   (null out)
                            (alert "Please specify an output file.")
                        )
                        (   (null
                                (setq dwgs
                                    (if (= "1" LH:Cur)
                                        ;; The current drawing. A drawing that
                                        ;; has never been saved has an empty
                                        ;; FullName, so the path and name are
                                        ;; assembled instead.
                                        (list
                                            (if (= "" (vla-get-fullname acdoc))
                                                (strcat (LayerHarvest:FixDir (vla-get-path acdoc))
                                                        "\\" (vla-get-name acdoc))
                                                (vla-get-fullname acdoc)
                                            )
                                        )
                                        (LayerHarvest:AllFiles LH:Dir (= "1" LH:Sub) "*.dwg")
                                    )
                                )
                            )
                            (alert "No drawing files were found.")
                        )
                        (   (done_dialog 1))
                    )
                )
            )

            (setq result (start_dialog)
                  dch    (unload_dialog dch)
            )
            (vl-file-delete dcl)
            (setq dcl nil)

            (if (/= 1 result)
                (princ "\nCancelled.")
                (progn
                    ;; ---- read every drawing -------------------------------
                    (setq dbx (LayerHarvest:DbxDocument))
                    (foreach dwg dwgs
                        (if (setq doc
                                (cond
                                    ;;  The current drawing.
                                    (   (= "1" LH:Cur) acdoc)
                                    ;;  Already open in this session: use the
                                    ;;  live document, or ObjectDBX would read
                                    ;;  the stale copy from disk.
                                    (   (cdr (assoc (strcase dwg) odbx)))
                                    ;;  Not open: pull it in through ObjectDBX.
                                    (   (and dbx
                                             (not (vl-catch-all-error-p
                                                      (vl-catch-all-apply 'vla-open (list dbx dwg))))
                                        )
                                        dbx
                                    )
                                )
                            )
                            (progn
                                (setq data (cons (cons dwg
                                                       (LayerHarvest:Read doc LH:Bits
                                                                          (= "1" LH:Xref)))
                                                 data))
                                (princ (strcat "\n--> " (vl-filename-base dwg) ".dwg"))
                            )
                            (princ (strcat "\n**  Unable to open: " (vl-filename-base dwg) ".dwg"))
                        )
                    )
                    (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
                        (progn (vlax-release-object dbx) (setq dbx nil))
                    )

                    ;; ---- write the output ---------------------------------
                    (setq data (vl-sort data '(lambda ( a b ) (< (car a) (car b)))))

                    (cond
                        (   (null data)
                            (princ "\nNo layer data was extracted.")
                        )
                        (   (null (setq des (open out "w")))
                            (alert (strcat "The output file could not be created:\n\n" out
                                           "\n\nCheck that you have write permission for that "
                                           "folder, and that the file is not already open."))
                        )
                        (   t
                            ;; Keep only the headings whose bit is set, so the
                            ;; columns match the extracted data exactly. The
                            ;; counter starts at 0 and becomes 1 on the first
                            ;; pass, which is the Layer column's bit.
                            (setq heads
                                (   (lambda ( bit )
                                        (vl-remove-if-not
                                           '(lambda ( title )
                                                (= (setq bit (if (zerop bit) 1 (lsh bit 1)))
                                                   (logand bit LH:Bits))
                                            )
                                            *LayerHarvest:Titles*
                                        )
                                    )
                                    0
                                )
                            )
                            (setq ext (strcase (vl-filename-extension out)))

                            (cond
                                (   (= ".TXT" ext) (LayerHarvest:WriteTxt data heads))
                                (   (= ".XML" ext) (LayerHarvest:WriteXml data heads))
                                (   t              (LayerHarvest:WriteCsv data heads))
                            )

                            (setq des (close des))
                            (princ (strcat "\nExtraction complete: " (itoa (length data))
                                           " drawing" (if (= 1 (length data)) "" "s")
                                           " written to " out))
                            (LayerHarvest:WriteConfig cfg (mapcar 'eval syms))
                        )
                    )
                )
            )
        )
    )

    (LayerHarvest:Restore)
    (princ)
)

;;; ===========================================================================
;;;                      D A T A   E X T R A C T I O N
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:Read
;;;
;;; Reads the layer table of one document and returns a list of rows, each a
;;; list of strings in column order.
;;;
;;; The accessors are held in a fixed list, in REVERSE column order, and the
;;; bit counter is shifted RIGHT from 2048. So the first accessor is tested
;;; against 1024 (Description) and the last against 1 (Layer name). Building
;;; the row by consing then puts the values back into forward order.
;;;
;;; Doing it this way means adding a column is a matter of adding one
;;; accessor and one heading; no index arithmetic changes.
;;;
;;;   doc  - a document object, live or ObjectDBX
;;;   bits - which columns to extract
;;;   xref - non-nil to include xref-dependent layers
;;;
;;; Returns the rows, sorted by layer name.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:Read ( doc bits xref / LayerHarvest:YN accessors rows )

    ;; Booleans read far better as YES and NO than as :vlax-true.
    (defun LayerHarvest:YN ( v ) (if (= :vlax-true v) "YES" "NO"))

    (setq accessors
       '(
            ;; Description exists only from AutoCAD 2000i onward, so it is
            ;; tested for rather than assumed.
            (lambda ( x ) (if (vlax-property-available-p x 'description)
                              (vla-get-description x) ""))
            (lambda ( x ) (LayerHarvest:YN (vla-get-viewportdefault x)))
            (lambda ( x ) (LayerHarvest:YN (vla-get-freeze    x)))
            (lambda ( x ) (LayerHarvest:YN (vla-get-lock      x)))
            (lambda ( x ) (LayerHarvest:YN (vla-get-layeron   x)))
            (lambda ( x ) (vla-get-plotstylename x))
            (lambda ( x ) (LayerHarvest:YN (vla-get-plottable x)))
            ;; Lineweight is stored in hundredths of a millimetre; the
            ;; negative values are the inherited settings.
            (lambda ( x / w )
                (if (minusp (setq w (vla-get-lineweight x)))
                    "DEFAULT"
                    (rtos (/ w 100.) 2 2)
                )
            )
            (lambda ( x ) (vla-get-linetype x))
            ;; A layer set to a true colour has no meaningful ACI number, so
            ;; its red, green and blue components are reported instead.
            (lambda ( x / tc )
                (if (= accolormethodbyaci
                       (vla-get-colormethod (setq tc (vla-get-truecolor x))))
                    (itoa (vla-get-color x))
                    (vl-prin1-to-string
                        (LayerHarvest:Join
                            (mapcar '(lambda ( p ) (itoa (vlax-get-property tc p)))
                                   '(red green blue))
                            ","
                        )
                    )
                )
            )
            (lambda ( x ) (vla-get-name x))
        )
    )

    (vlax-for layer (vla-get-layers doc)
        ;; A vertical bar in the name marks an xref-dependent layer. Those
        ;; belong to the referenced drawing, not this one.
        (if (or xref (not (wcmatch (vla-get-name layer) "*|*")))
            (setq rows
                (cons
                    (   (lambda ( bit / row )
                            (foreach fn accessors
                                (if (= (setq bit (lsh bit -1)) (logand bit bits))
                                    (setq row (cons
                                                  ;; Guarded: a document from
                                                  ;; an older release may not
                                                  ;; support every property,
                                                  ;; and one missing value
                                                  ;; must not abort the run.
                                                  (   (lambda ( r )
                                                          (if (vl-catch-all-error-p r) "" r)
                                                      )
                                                      (vl-catch-all-apply (eval fn) (list layer))
                                                  )
                                                  row
                                              )
                                    )
                                )
                            )
                            row
                        )
                        2048
                    )
                    rows
                )
            )
        )
    )
    (vl-sort rows '(lambda ( a b ) (< (car a) (car b))))
)

;;; ===========================================================================
;;;                          O U T P U T
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:WriteTxt
;;;
;;; Writes the fixed-width report.
;;;
;;; Each column is made wide enough for its widest value plus five, so the
;;; columns line up down the whole file even when one drawing has a much
;;; longer layer name than the rest. The widths are computed in one pass over
;;; every row of every drawing before anything is written.
;;;
;;; The trailing padding is trimmed off each line, so the file has no ragged
;;; run of spaces at the end of every row.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:WriteTxt ( data heads / all col pad widths )

    (setq pad (nth (atoi LH:Pad) '(32 9 46 45 44 59))   ;; space tab . - , ;
          all (apply 'append (mapcar 'cdr data))        ;; every row, all drawings
    )

    ;; Peel one column at a time off the front of every row, measuring as it
    ;; goes, until the rows are exhausted.
    (setq col heads)
    (while (car (mapcar 'car all))
        (setq widths (cons (+ 5 (apply 'max (mapcar 'strlen (cons (car col) (mapcar 'car all)))))
                           widths)
              col    (cdr col)
              all    (mapcar 'cdr all)
        )
    )
    (setq widths (reverse widths))

    (write-line
        (strcat "Layer Harvest: "
                (menucmd "m=$(edtime,$(getvar,DATE),DDDD DD MONTH YYYY HH:MM:SS)"))
        des
    )
    (foreach dwg data
        (write-line (strcat "\nDrawing File:  " (car dwg)) des)
        (foreach row (cons heads (cdr dwg))
            (write-line
                (vl-string-right-trim (chr pad)
                    (apply 'strcat
                        (mapcar '(lambda ( str len ) (LayerHarvest:Pad str pad len))
                                row widths)
                    )
                )
                des
            )
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:WriteCsv
;;;
;;; Writes the CSV file.
;;;
;;; The separator comes from the user's own Windows regional settings rather
;;; than being assumed to be a comma. In much of Europe the list separator is
;;; a semicolon, and a comma-separated file opens there as a single unusable
;;; column.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:WriteCsv ( data heads / sep )
    (setq sep
        (cond
            (   (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList"))
            (   ",")
        )
    )
    (write-line
        (strcat "Layer Harvest:" sep
                (menucmd "m=$(edtime,$(getvar,DATE),DDDD DD MONTH YYYY HH:MM:SS)"))
        des
    )
    (foreach dwg data
        (write-line (strcat "\nDrawing File:" sep (car dwg)) des)
        (foreach row (cons heads (cdr dwg))
            (write-line (LayerHarvest:Join (mapcar '(lambda ( s ) (LayerHarvest:CsvQuote s sep)) row) sep) des)
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:WriteXml
;;;
;;; Writes either plain XML (optionally with a stylesheet) or a SpreadsheetML
;;; workbook Excel will open with one worksheet per drawing.
;;;
;;; The tags are derived from the headings by lower-casing them and replacing
;;; spaces with underscores, because a space is not legal in an XML tag name.
;;; ---------------------------------------------------------------------------

;;; sfile is deliberately NOT declared local here: it belongs to the calling
;;; command, whose cleanup closes it if the write is interrupted part-way.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:WriteXml ( data heads / xheads )

    (setq xheads
        (mapcar '(lambda ( h ) (vl-string-translate " " "_" (strcase h t))) heads)
    )

    (if (= "1" LH:Excel)

        ;;  ---- SpreadsheetML workbook ----
        (progn
            (foreach line
               '(
                    "<?xml version=\"1.0\"?>"
                    "<?mso-application progid=\"Excel.Sheet\"?>"
                    "<Workbook"
                    "xmlns=\"urn:schemas-microsoft-com:office:spreadsheet\""
                    "xmlns:o=\"urn:schemas-microsoft-com:office:office\""
                    "xmlns:x=\"urn:schemas-microsoft-com:office:excel\""
                    "xmlns:ss=\"urn:schemas-microsoft-com:office:spreadsheet\""
                    "xmlns:html=\"http://www.w3.org/TR/REC-html40\">"
                )
                (write-line line des)
            )
            (foreach dwg data
                (write-line (strcat "\t<Worksheet ss:Name=\""
                                    (LayerHarvest:Escape (vl-filename-base (car dwg))) "\">") des)
                (write-line
                    (strcat "\t\t<Table ss:ExpandedColumnCount=\"" (itoa (length heads)) "\""
                            " ss:ExpandedRowCount=\"" (itoa (1+ (length (cdr dwg))))
                            "\" x:FullColumns=\"1\" x:FullRows=\"1\" ss:DefaultRowHeight=\"15\">")
                    des
                )
                (write-line "\t\t\t<Row>" des)
                (foreach h heads
                    (write-line (strcat "\t\t\t\t<Cell><Data ss:Type=\"String\">"
                                        (LayerHarvest:Escape h) "</Data></Cell>") des)
                )
                (write-line "\t\t\t</Row>" des)
                (foreach row (cdr dwg)
                    (write-line "\t\t\t<Row>" des)
                    (foreach val row
                        (write-line
                            (strcat "\t\t\t\t<Cell><Data ss:Type=\""
                                    ;; Excel right-aligns and sums numeric
                                    ;; cells, so values that are numbers are
                                    ;; declared as such. read is guarded
                                    ;; because a layer name can contain
                                    ;; characters it cannot parse.
                                    (if (LayerHarvest:IsNumber val) "Number" "String")
                                    "\">" (LayerHarvest:Escape val) "</Data></Cell>")
                            des
                        )
                    )
                    (write-line "\t\t\t</Row>" des)
                )
                (write-line "\t\t</Table>" des)
                (write-line "\t</Worksheet>" des)
            )
            (write-line "</Workbook>" des)
        )

        ;;  ---- structured XML ----
        (progn
            (write-line "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>" des)
            (if (= "1" LH:Xsl)
                (write-line (strcat "<?xml-stylesheet type=\"text/xsl\" href=\""
                                    (vl-filename-base out) ".xsl\"?>") des)
            )
            (write-line "<extraction>" des)
            (write-line
                (strcat "\t<title>Layer Harvest: "
                        (menucmd "m=$(edtime,$(getvar,DATE),DDDD DD MONTH YYYY HH:MM:SS)")
                        "</title>")
                des
            )
            (foreach dwg data
                (write-line "\t<file>" des)
                (write-line (strcat "\t\t<filename>" (LayerHarvest:Escape (car dwg))
                                    "</filename>") des)
                (foreach row (cdr dwg)
                    (write-line "\t\t<layer_item>" des)
                    (mapcar
                       '(lambda ( tag val )
                            (write-line (strcat "\t\t\t<" tag ">" (LayerHarvest:Escape val)
                                                "</" tag ">") des)
                        )
                        xheads row
                    )
                    (write-line "\t\t</layer_item>" des)
                )
                (write-line "\t</file>" des)
            )
            (write-line "</extraction>" des)

            ;; The stylesheet turns the raw XML into a readable banded table
            ;; when the file is opened in a browser. It is written alongside
            ;; the XML with the same base name, which is what the
            ;; xml-stylesheet instruction above points at.
            (if (= "1" LH:Xsl)
                (if (setq sfile (open (strcat (vl-filename-directory out) "\\"
                                              (vl-filename-base out) ".xsl") "w"))
                    (progn
                        (foreach line
                            (append
                                (list
                                    "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>"
                                    "<xsl:stylesheet version=\"1.0\" xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\">"
                                    "<xsl:template match=\"/\">"
                                    "<html>"
                                    "\t<head><title>Layer Harvest</title></head>"
                                    "\t<body style=\"font-family:Verdana,Arial;font-size:10pt;background-color:#cccccc;\">"
                                    "\t\t<h3><xsl:value-of select=\"extraction/title\"/></h3>"
                                    "\t\t<table border=\"1\" cellpadding=\"5\" style=\"border-collapse:collapse;border:1px solid navy;\">"
                                    "\t\t\t<xsl:for-each select=\"extraction/file\">"
                                    "\t\t\t\t<tr bgcolor=\"#2e2e2e\">"
                                    "\t\t\t\t<th colspan=\"11\" style=\"text-align:left;color:silver;\"><xsl:value-of select=\"filename\"/></th>"
                                    "\t\t\t\t</tr>"
                                    "\t\t\t\t<tr bgcolor=\"#a8c3f3\">"
                                )
                                (mapcar '(lambda ( h ) (strcat "\t\t\t\t<th>" h "</th>")) heads)
                                (list
                                    "\t\t\t\t</tr>"
                                    "\t\t\t\t<xsl:for-each select=\"layer_item\">"
                                    "\t\t\t\t\t<tr>"
                                    ;; Alternate row shading, so a long table
                                    ;; stays readable across the page.
                                    "\t\t\t\t\t<xsl:choose>"
                                    "\t\t\t\t\t\t<xsl:when test=\"position() mod 2 = 0\">"
                                    "\t\t\t\t\t\t\t<xsl:attribute name=\"bgcolor\">#a8c3f3</xsl:attribute>"
                                    "\t\t\t\t\t\t</xsl:when>"
                                    "\t\t\t\t\t\t<xsl:otherwise>"
                                    "\t\t\t\t\t\t\t<xsl:attribute name=\"bgcolor\">#5c97ff</xsl:attribute>"
                                    "\t\t\t\t\t\t</xsl:otherwise>"
                                    "\t\t\t\t\t</xsl:choose>"
                                    (strcat "\t\t\t\t\t<td style=\"font-weight:bold;\"><xsl:value-of select=\""
                                            (car xheads) "\"/></td>")
                                )
                                (mapcar '(lambda ( tag )
                                             (strcat "\t\t\t\t\t<td><xsl:value-of select=\""
                                                     tag "\"/></td>"))
                                        (cdr xheads))
                                (list
                                    "\t\t\t\t\t</tr>"
                                    "\t\t\t\t</xsl:for-each>"
                                    "\t\t\t</xsl:for-each>"
                                    "\t\t</table>"
                                    "\t</body>"
                                    "</html>"
                                    "</xsl:template>"
                                    "</xsl:stylesheet>"
                                )
                            )
                            (write-line line sfile)
                        )
                        (close sfile)
                        (setq sfile nil)
                    )
                    (princ "\n** Unable to create the XSL stylesheet.")
                )
            )
        )
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:IsNumber
;;;
;;; Returns non-nil if a string represents a number, for deciding whether an
;;; XML cell should be declared numeric.
;;;
;;; read is used because it accepts every numeric form AutoLISP does, but it
;;; raises an error on strings it cannot parse -- a layer named "A(B" for
;;; instance -- so it is caught.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:IsNumber ( str / val )
    (setq val (vl-catch-all-apply 'read (list str)))
    (and (not (vl-catch-all-error-p val)) (numberp val))
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:Escape
;;;
;;; Escapes the five characters XML reserves.
;;;
;;; The ampersand MUST be replaced first. Replacing "<" with "&lt;"
;;; introduces an ampersand of its own, so escaping ampersands afterwards
;;; would turn it into "&amp;lt;" and corrupt every escaped character in the
;;; file.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:Escape ( str / LayerHarvest:SubstAll )

    ;; vl-string-subst replaces one occurrence; this repeats until there are
    ;; none left, stepping past each replacement so the search cannot loop
    ;; forever on text it has just inserted.
    (defun LayerHarvest:SubstAll ( new old str / pos len )
        (setq pos 0
              len (strlen new)
        )
        (while (and (< pos (strlen str)) (setq pos (vl-string-search old str pos)))
            (setq str (vl-string-subst new old str pos)
                  pos (+ pos len)
            )
        )
        str
    )

    (foreach pair
       '(
            ("&amp;"  . "&")     ;; must be first
            ("&lt;"   . "<")
            ("&gt;"   . ">")
            ("&apos;" . "'")
            ("&quot;" . "\"")
        )
        (setq str (LayerHarvest:SubstAll (car pair) (cdr pair) str))
    )
    str
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:CsvQuote
;;;
;;; Wraps a value in quotes if it contains the separator or a quote, and
;;; doubles any quotes inside it -- the standard CSV escaping rules.
;;;
;;; A true colour reported as "255,0,0" would otherwise split across three
;;; columns and shift every later value along.
;;;
;;; The separator is backquote-escaped inside the wcmatch pattern, because it
;;; could itself be a wildcard character.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:CsvQuote ( str sep / pos )
    (cond
        (   (wcmatch str (strcat "*[`" sep "\"]*"))
            (setq pos 0)
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str)
    )
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:Pad
;;;
;;; Returns a string padded on the right with the given character to the
;;; given length. Used to line the fixed-width report's columns up.
;;;
;;; Working in character codes rather than strings means one loop builds the
;;; padding, instead of a strcat per character.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:Pad ( str chr len )
    (   (lambda ( lst )
            (while (< (length lst) len) (setq lst (cons chr lst)))
            (vl-list->string (reverse lst))
        )
        (reverse (vl-string->list str))
    )
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:Join
;;;
;;; Joins a list of strings with the given separator between each pair.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:Join ( lst del / out )
    (setq out (car lst))
    (foreach x (cdr lst) (setq out (strcat out del x)))
    out
)

;;; ===========================================================================
;;;                         F I L E   A C C E S S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:DbxDocument
;;;
;;; Creates and returns an ObjectDBX document object, or nil.
;;;
;;; The ProgID is version-stamped from AutoCAD 2004 (version 16) onward, so
;;; the major version number is read from ACADVER and appended. Older
;;; releases use the unversioned name.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:DbxDocument ( / obj ver )
    (setq ver (atoi (getvar 'acadver))
          obj (vl-catch-all-apply 'vla-getinterfaceobject
                  (list (vlax-get-acad-object)
                      (if (< ver 16)
                          "objectdbx.axdbdocument"
                          (strcat "objectdbx.axdbdocument." (itoa ver))
                      )
                  )
              )
    )
    (if (vl-catch-all-error-p obj)
        (progn (princ "\nUnable to interface with ObjectDBX.") nil)
        obj
    )
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:AllFiles
;;;
;;; Returns the full paths of every file in a folder matching the filter,
;;; optionally descending into every sub-folder.
;;;
;;;   dir    - folder to search
;;;   subs   - non-nil to include sub-folders, at any depth
;;;   filter - wildcard filter, e.g. "*.dwg"
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:AllFiles ( dir subs filter / LayerHarvest:SubFolders folders )

    ;; "." and ".." are removed by name rather than by position: their place
    ;; in the listing is not guaranteed, and descending into ".." would
    ;; recurse upwards forever.
    (defun LayerHarvest:SubFolders ( folder / here )
        (apply 'append
            (mapcar
               '(lambda ( f )
                    (setq here (strcat folder "\\" f))
                    (cons here (LayerHarvest:SubFolders here))
                )
                (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
            )
        )
    )

    (if (and dir (vl-file-directory-p (setq dir (LayerHarvest:FixDir dir))))
        (progn
            (setq folders (cons dir (if subs (LayerHarvest:SubFolders dir))))
            (apply 'append
                (mapcar
                   '(lambda ( folder )
                        (mapcar '(lambda ( name ) (strcat folder "\\" name))
                                (vl-directory-files folder filter 1))
                    )
                    folders
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:PickFolder
;;;
;;; Opens the native Windows folder picker and returns the chosen path, or
;;; nil.
;;;
;;; Two COM objects are created and both must be released explicitly; an
;;; unreleased Shell object stays resident for the whole AutoCAD session. The
;;; releases sit outside the catch so they happen even when the picker fails.
;;;
;;;   msg - prompt shown in the picker
;;;   dir - starting folder, or nil
;;;   flg - Shell BROWSEINFO flags
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:PickFolder ( msg dir flg / err fold path self shell )
    (setq err
        (vl-catch-all-apply
           '(lambda ( / app hwnd )
                (setq app   (vlax-get-acad-object)
                      shell (vla-getinterfaceobject app "Shell.Application")
                      hwnd  (vl-catch-all-apply 'vla-get-hwnd (list app))
                      fold  (vlax-invoke-method shell 'browseforfolder
                                (if (vl-catch-all-error-p hwnd) 0 hwnd) msg flg dir)
                )
                ;; The Folder object has no path of its own; its Self
                ;; property is the FolderItem that does.
                (if fold
                    (setq self (vlax-get-property fold 'self)
                          path (LayerHarvest:FixDir (vlax-get-property self 'path))
                    )
                )
            )
        )
    )
    (if self  (vlax-release-object self))
    (if fold  (vlax-release-object fold))
    (if shell (vlax-release-object shell))
    (if (vl-catch-all-error-p err) nil path)
)

;;; ---------------------------------------------------------------------------
;;; LayerHarvest:WriteConfig / LayerHarvest:ReadConfig
;;;
;;; Save and reload the settings, one value per line.
;;;
;;; Values are written in printed form and read back with read, which
;;; round-trips strings and numbers faithfully -- quotes and backslashes in
;;; folder paths included. The read is forgiving: a short or hand-edited file
;;; simply leaves the remaining settings at their defaults.
;;; ---------------------------------------------------------------------------

(defun LayerHarvest:WriteConfig ( cfg lst / des )
    (if (setq des (open cfg "w"))
        (progn
            (foreach x lst (write-line (vl-prin1-to-string x) des))
            (close des)
            t
        )
    )
)

(defun LayerHarvest:ReadConfig ( cfg syms / des line )
    (if (and (setq cfg (findfile cfg))
             (setq des (open cfg "r"))
        )
        (progn
            (foreach sym syms
                (if (setq line (read-line des))
                    (   (lambda ( val )
                            (if (not (vl-catch-all-error-p val)) (set sym val))
                        )
                        (vl-catch-all-apply 'read (list line))
                    )
                )
            )
            (close des)
            t
        )
    )
)

(princ "\nLayerHarvest loaded. Type LAYERHARVEST to extract layer data from drawings.")
(princ)

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