;; =====================================================================
;; AreaLabels.lsp - area labels for closed polylines
;;                  + area totals by layer in an Excel / CSV file
;; Command: AREALABELS
;; AutoCAD / GstarCAD (AutoLISP). Description and installation:
;; https://fixcontrol.co/tools/autocad-lisp-scripts
;;
;; WHAT IT DOES:
;;   1. Deletes old labels from the AREA_LABELS layer.
;;   2. You select closed polylines - each one gets an MTEXT label:
;;      layer name + area in m2 (layer AREA_LABELS, text style ARIAL -
;;      both created if missing).
;;   3. Areas are summed by layer and saved to a file - the save dialog
;;      lets you choose the folder, name and file 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.
;;
;; OPTIONS (SETTINGS at the start of the function below):
;;   textSize    - label text height (drawing units)
;;   areaDivisor - conversion of area to m2:
;;                 drawing in cm -> 10000.0, in mm -> 1000000.0, in m -> 1.0
;;   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 AREA_LABELS layer.
;; =====================================================================

(defun c:AreaLabels (/ *error* logmsg oldLayer ss i ent entData layer area adjustedArea centroidPt oldEnts
                       textSize areaDivisor exportFile fileSuffix areaDict item dictItem rows fname)
  (vl-load-com)

  ;; ---- SETTINGS ----
  (setq textSize 40.0)
  (setq areaDivisor 10000.0)
  (setq exportFile T)
  (setq fileSuffix "_areas")

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

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

  (logmsg "==================================================")
  (logmsg "Starting AreaLabels command")

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

  ;; label layer
  (if (not (tblsearch "LAYER" "AREA_LABELS"))
    (progn
      (command "_.-LAYER" "_M" "AREA_LABELS" "_C" "7" "" "")
      (logmsg "Created layer AREA_LABELS")
    )
    (logmsg "Layer AREA_LABELS already exists")
  )
  (setvar 'CLAYER "AREA_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 "AREA_LABELS"))))
  (if oldEnts
    (progn
      (command "_.ERASE" oldEnts "")
      (logmsg (strcat "Removed old labels: " (itoa (sslength oldEnts)) " objects"))
    )
    (logmsg "No old labels to remove")
  )

  (setq areaDict nil)

  ;; closed polylines
  (if (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1))))
    (progn
      (logmsg (strcat "Found " (itoa (sslength ss)) " closed polylines"))
      (setq i 0)
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq entData (entget ent))
        (setq layer (cdr (assoc 8 entData)))

        (setq area (vl-catch-all-apply 'vla-get-area (list (vlax-ename->vla-object ent))))
        (if (vl-catch-all-error-p area)
          (progn
            (setq area 0.0)
            (logmsg "  ! ERROR calculating area")
          )
          (progn
            (setq adjustedArea (/ area areaDivisor))
            ;; total for the layer (positive areas only)
            (if (> area 0)
              (if (setq dictItem (assoc layer areaDict))
                (setq areaDict (subst (cons layer (+ adjustedArea (cdr dictItem))) dictItem areaDict))
                (setq areaDict (cons (cons layer adjustedArea) areaDict))
              )
            )
          )
        )

        (setq centroidPt (AreaLabels-center ent))

        (if (and (> area 0) centroidPt)
          (entmake
            (list
              '(0 . "MTEXT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbMText")
              (cons 10 centroidPt)
              (cons 40 textSize)
              (cons 1 (strcat layer "\\P" (rtos adjustedArea 2 2) " m2"))
              (cons 7 "ARIAL")
              (cons 71 5)
              (cons 8 "AREA_LABELS")
            )
          )
        )
        (setq i (1+ i))
      )
    )
    (logmsg "No closed polylines found")
  )

  ;; export totals to the file chosen by the user
  (if (and exportFile areaDict)
    (progn
      (setq rows (list (list "symbol" "area")))
      (foreach item (vl-sort areaDict '(lambda (a b) (< (car a) (car b))))
        (setq rows (cons (list (vl-string-trim "_" (car item)) (cdr item)) rows))
      )
      (setq fname (getfiled "Save area totals"
                            (strcat (getvar 'DWGPREFIX) (vl-filename-base (getvar 'DWGNAME)) fileSuffix ".xlsx")
                            "xlsx;xls;csv" 1))
      (if fname
        (if (setq fname (AreaLabels-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)
)

;; centre of the object's bounding box
(defun AreaLabels-center (ent / minpt maxpt)
  (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
  (setq minpt (vlax-safearray->list minpt))
  (setq maxpt (vlax-safearray->list maxpt))
  (list
    (/ (+ (car minpt) (car maxpt)) 2.0)
    (/ (+ (cadr minpt) (cadr maxpt)) 2.0)
    0.0
  )
)

;; ---------------------------------------------------------------------
;; 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 AreaLabels-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 (AreaLabels-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))
        (AreaLabels-save-csv fname rows)
      )
    )
    (AreaLabels-save-csv fname rows)
  )
)

;; save via Excel (separate, hidden instance); fmt: 51 = xlsx, 56 = xls
(defun AreaLabels-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 AreaLabels-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 "\"" (AreaLabels-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 AreaLabels-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 "\nAREALABELS loaded. Type AREALABELS to run.")
(princ)