;; =====================================================================
;; LineLabels.lsp - length labels for lines and polylines
;;                  + length totals by layer in an Excel / CSV file
;; Command: LINELABELS
;; AutoCAD / GstarCAD (AutoLISP). Description and installation:
;; https://fixcontrol.co/tools/autocad-lisp-scripts
;;
;; WHAT IT DOES:
;;   1. Asks which objects to label [Lines/Polylines/All]:
;;        Lines      - LINE objects only,
;;        Polylines  - LWPOLYLINE / POLYLINE only (whole polyline length),
;;        All        - lines and polylines.
;;      The last choice is remembered until the program is closed
;;      (Enter = the same).
;;   2. Deletes old labels from the LENGTH_LABELS layer.
;;   3. You select objects - an MTEXT label is placed at the middle of
;;      each one: layer name + length in m (layer LENGTH_LABELS,
;;      style ARIAL - both created if missing).
;;   4. Lengths and object counts are summed by layer and saved to a
;;      file - the save dialog lets you choose the folder, name and format:
;;        .xlsx / .xls - via Excel (numbers as numbers, 2 decimals),
;;        .csv         - semicolon separator, decimal comma.
;;      If Excel is not installed, a CSV with the same name is saved.
;;      Cancelling the dialog = no export.
;;      Columns: symbol (layer) ; length [m] ; count [pcs]
;;
;; OPTIONS (SETTINGS at the start of the function below):
;;   textSize      - label text height (drawing units)
;;   lengthDivisor - conversion of length to metres:
;;                   drawing in cm -> 100.0, in mm -> 1000.0, in m -> 1.0
;;   defaultMode   - object choice suggested on the first run:
;;                   "Lines", "Polylines" or "All"
;;   exportFile    - T = save totals to a file, nil = labels only
;;   fileSuffix    - ending of the suggested file name (drawing name + ...)
;; NOTE: before labelling it deletes ALL texts on the LENGTH_LABELS layer.
;; =====================================================================

(defun c:LineLabels (/ *error* logmsg oldLayer ss i ent layer len adjustedLength midPt oldEnts mode filter
                       textSize lengthDivisor defaultMode exportFile fileSuffix lengthDict item dictItem rows fname)
  (vl-load-com)

  ;; ---- SETTINGS ----
  (setq textSize 40.0)
  (setq lengthDivisor 100.0)
  (setq defaultMode "All")
  (setq exportFile T)
  (setq fileSuffix "_lengths")

  (defun logmsg (msg)
    (princ msg)
    (princ "\n")
  )

  (defun *error* (msg)
    (logmsg (strcat "! ERROR: " msg))
    (if oldLayer (setvar 'CLAYER oldLayer))
    (logmsg "--------------------------------------------------")
    (princ)
  )

  (logmsg "==================================================")
  (logmsg "Starting LineLabels command")

  ;; object type choice (remembered in a global variable)
  (if (not (member *LineLabels-mode* '("Lines" "Polylines" "All"))) (setq *LineLabels-mode* defaultMode))
  (initget "Lines Polylines All")
  (setq mode (getkword (strcat "\nObjects to label [Lines/Polylines/All] <" *LineLabels-mode* ">: ")))
  (if mode (setq *LineLabels-mode* mode) (setq mode *LineLabels-mode*))
  (setq filter
    (cond
      ((= mode "Lines") "LINE")
      ((= mode "Polylines") "LWPOLYLINE,POLYLINE")
      (t "LINE,LWPOLYLINE,POLYLINE")
    )
  )
  (logmsg (strcat "Objects: " mode " (" filter ")"))

  (setq oldLayer (getvar 'CLAYER))
  (logmsg (strcat "Current layer: " oldLayer))
  (logmsg (strcat "Text size: " (rtos textSize 2 4)))

  ;; label layer
  (if (not (tblsearch "LAYER" "LENGTH_LABELS"))
    (progn
      (command "_.-LAYER" "_M" "LENGTH_LABELS" "_C" "7" "" "")
      (logmsg "Created layer LENGTH_LABELS")
    )
    (logmsg "Layer LENGTH_LABELS already exists")
  )
  (setvar 'CLAYER "LENGTH_LABELS")

  ;; Arial text style
  (if (not (tblsearch "STYLE" "ARIAL"))
    (progn
      (command "_.-STYLE" "ARIAL" "Arial" 0 1 0 "" "" "")
      (logmsg "Created text style ARIAL")
    )
    (logmsg "Text style ARIAL already exists")
  )
  (setvar 'TEXTSTYLE "ARIAL")

  ;; delete old labels
  (setq oldEnts (ssget "_X" (list '(0 . "TEXT,MTEXT") (cons 8 "LENGTH_LABELS"))))
  (if oldEnts
    (progn
      (command "_.ERASE" oldEnts "")
      (logmsg (strcat "Removed old labels: " (itoa (sslength oldEnts)) " objects"))
    )
    (logmsg "No old labels to remove")
  )

  ;; lengthDict: list of (layer length count)
  (setq lengthDict nil)

  (if (setq ss (ssget (list (cons 0 filter))))
    (progn
      (logmsg (strcat "Found " (itoa (sslength ss)) " objects"))
      (setq i 0)
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq layer (cdr (assoc 8 (entget ent))))

        (setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
        (setq adjustedLength (/ len lengthDivisor))

        ;; point at half the object's length
        (setq midPt (vlax-curve-getPointAtDist ent (/ len 2.0)))
        (if (not midPt) (setq midPt (vlax-curve-getStartPoint ent)))
        (setq midPt (list (car midPt) (cadr midPt) 0.0))

        ;; total and count for the layer
        (if (setq dictItem (assoc layer lengthDict))
          (setq lengthDict (subst (list layer (+ adjustedLength (cadr dictItem)) (1+ (caddr dictItem)))
                                  dictItem lengthDict))
          (setq lengthDict (cons (list layer adjustedLength 1) lengthDict))
        )

        (entmake
          (list
            '(0 . "MTEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbMText")
            (cons 10 midPt)
            (cons 40 textSize)
            (cons 1 (strcat layer "\\P" (rtos adjustedLength 2 2) " m"))
            (cons 7 "ARIAL")
            (cons 71 5)
            (cons 8 "LENGTH_LABELS")
          )
        )
        (setq i (1+ i))
      )
    )
    (logmsg "No objects found")
  )

  ;; export totals to the file chosen by the user
  (if (and exportFile lengthDict)
    (progn
      (setq rows (list (list "symbol" "length" "count")))
      (foreach item (vl-sort lengthDict '(lambda (a b) (< (car a) (car b))))
        (setq rows (cons (list (vl-string-trim " " (vl-string-trim "_" (car item))) (cadr item) (caddr item))
                         rows))
      )
      (setq fname (getfiled "Save length totals"
                            (strcat (getvar 'DWGPREFIX) (vl-filename-base (getvar 'DWGNAME)) fileSuffix ".xlsx")
                            "xlsx;xls;csv" 1))
      (if fname
        (if (setq fname (LineLabels-save fname (reverse rows) T))
          (logmsg (strcat "Exported to: " fname))
          (logmsg "! Export failed")
        )
        (logmsg "Export canceled")
      )
    )
  )

  (setvar 'CLAYER oldLayer)
  (logmsg "Command completed successfully")
  (logmsg "==================================================")
  (princ)
)

;; ---------------------------------------------------------------------
;; Save a table to a file. rows = list of rows, cells: text or number.
;; header = T -> the first row holds headers (bold in Excel).
;; .xlsx / .xls -> via Excel, .csv -> semicolon + decimal comma.
;; Without Excel a CSV with the same name is saved. Returns the path or nil.
;; ---------------------------------------------------------------------
(defun LineLabels-save (fname rows header / ext)
  (setq ext (vl-filename-extension fname))
  (if (not ext) (setq fname (strcat fname ".xlsx") ext ".xlsx"))
  (setq ext (strcase ext))
  (if (member ext '(".XLSX" ".XLS"))
    (if (LineLabels-save-excel fname rows header (if (= ext ".XLS") 56 51))
      fname
      (progn
        (setq fname (strcat (vl-filename-directory fname) "\\" (vl-filename-base fname) ".csv"))
        (princ (strcat "\nSaving via Excel failed - saving CSV instead: " fname))
        (LineLabels-save-csv fname rows)
      )
    )
    (LineLabels-save-csv fname rows)
  )
)

;; save via Excel (separate, hidden instance); fmt: 51 = xlsx, 56 = xls
(defun LineLabels-save-excel (fname rows header fmt / xl wb sh cells cell r c res)
  (setq xl (vl-catch-all-apply 'vlax-create-object '("Excel.Application")))
  (if (and xl (not (vl-catch-all-error-p xl)))
    (progn
      (setq res
        (vl-catch-all-apply
          '(lambda ()
             (vlax-put-property xl 'DisplayAlerts :vlax-false)
             (setq wb (vlax-invoke-method (vlax-get-property xl 'Workbooks) 'Add))
             (setq sh (vlax-get-property wb 'ActiveSheet))
             (setq cells (vlax-get-property sh 'Cells))
             (setq r 1)
             (foreach row rows
               (setq c 1)
               (foreach val row
                 (setq cell (vlax-get-property cells 'Item r c))
                 (if (= (type cell) 'VARIANT) (setq cell (vlax-variant-value cell)))
                 (cond
                   ((= (type val) 'STR)  (vlax-put-property cell 'NumberFormat "@"))
                   ((= (type val) 'REAL) (vlax-put-property cell 'NumberFormat "0.00"))
                 )
                 (vlax-put-property cell 'Value2 val)
                 (vlax-release-object cell)
                 (setq cell nil c (1+ c))
               )
               (setq r (1+ r))
             )
             (if header
               (vl-catch-all-apply
                 '(lambda ()
                    (vlax-put-property (vlax-get-property (vlax-get-property sh 'Range "1:1") 'Font) 'Bold :vlax-true)))
             )
             (vl-catch-all-apply
               '(lambda () (vlax-invoke-method (vlax-get-property sh 'Columns) 'AutoFit)))
             (vlax-invoke-method wb 'SaveAs fname fmt)
           )
        )
      )
      (if wb (vl-catch-all-apply 'vlax-invoke-method (list wb 'Close :vlax-false)))
      (vl-catch-all-apply 'vlax-invoke-method (list xl 'Quit))
      (foreach o (list cell cells sh wb xl)
        (if (and (= (type o) 'VLA-OBJECT) (not (vlax-object-released-p o)))
          (vlax-release-object o)
        )
      )
      (gc)
      (if (vl-catch-all-error-p res)
        (progn (princ (strcat "\nExcel error: " (vl-catch-all-error-message res))) nil)
        T
      )
    )
    (progn (princ "\nExcel is not available on this computer.") nil)
  )
)

;; save CSV: semicolon separator, decimal comma
(defun LineLabels-save-csv (fname rows / f line s)
  (if (setq f (open fname "w"))
    (progn
      (foreach row rows
        (setq line nil)
        (foreach val row
          (setq s
            (cond
              ((= (type val) 'REAL) (vl-string-translate "." "," (rtos val 2 2)))
              ((= (type val) 'INT) (itoa val))
              ((or (vl-string-search ";" val) (vl-string-search "\"" val))
               (strcat "\"" (LineLabels-dq val) "\""))
              (t val)
            )
          )
          (setq line (if line (strcat line ";" s) s))
        )
        (write-line (if line line "") f)
      )
      (close f)
      fname
    )
    (progn (princ (strcat "\nCannot write file: " fname)) nil)
  )
)

;; double the quotes (CSV)
(defun LineLabels-dq (s / p)
  (setq p 0)
  (while (setq p (vl-string-search "\"" s p))
    (setq s (strcat (substr s 1 p) "\"" (substr s (1+ p))) p (+ p 2))
  )
  s
)

(princ "\nLINELABELS loaded. Type LINELABELS to run.")
(princ)