;;; =========================================================================== ;;; GLFS - Add Surface Spot Elevation Labels ;;; Modified: DCL popup with TICKS for surface selection mode ;;; Fixed: DCL writing without unescaped quotes (no more malformed list) ;;; =========================================================================== (if (not *glfs-mode*) (setq *glfs-mode* "Drawing")) (if (not *glfs-zoom*) (setq *glfs-zoom* T)) (if (not *glfs-progress*) (setq *glfs-progress* T)) ;; --------------------------------------------------------------------------- ;; DCL path ;; --------------------------------------------------------------------------- (defun GLFS:DclPath ( ) (strcat (vl-string-right-trim "\\/" (getenv "TEMP")) "\\glfs_menu.dcl") ) ;; --------------------------------------------------------------------------- ;; DCL writer - uses a list of pre-built lines so no quote escaping is needed. ;; Each line is a plain string with NO embedded double quotes; we build the ;; quoted DCL attribute values by concatenating chr(34) (") explicitly. ;; --------------------------------------------------------------------------- (defun GLFS:WriteDCL ( / fn f lines q L) (setq fn (GLFS:DclPath)) (setq q (chr 34)) ;; the double-quote character, built at runtime (setq lines (list (strcat "glfs_menu : dialog { label = " q "Surface Spot Elevation Labels" q ";") (strcat " : boxed_radio_column { label = " q "Surface selection mode" q ";") (strcat " : radio_button { key = " q "mDraw" q "; label = " q "Pick surface from drawing" q "; }") (strcat " : radio_button { key = " q "mMenu" q "; label = " q "Choose from numbered list" q "; }") (strcat " : radio_button { key = " q "mAuto" q "; label = " q "Auto (use only surface if just one exists)" q "; }") " }" (strcat " : boxed_column { label = " q "Options" q ";") (strcat " : toggle { key = " q "optZoom" q "; label = " q "Zoom to selection before labeling" q "; }") (strcat " : toggle { key = " q "optProgress" q "; label = " q "Print batch progress" q "; }") " }" " ok_cancel;" "}" ) ) (if (setq f (open fn "w")) (progn (foreach L lines (write-line L f)) (close f) fn ) nil ) ) ;; --------------------------------------------------------------------------- ;; Dialog driver - returns (mode zoom progress) or nil ;; --------------------------------------------------------------------------- (defun GLFS:ShowMenu ( / dclFile dclId dclReturn mode zoom progress) (setq dclFile (GLFS:WriteDCL)) (if (null dclFile) nil (progn (setq dclId (load_dialog dclFile)) (if (or (null dclId) (<= dclId 0)) nil (progn (if (not (new_dialog "glfs_menu" dclId)) (progn (unload_dialog dclId) nil) (progn ;; Pre-tick from memory (cond ((= *glfs-mode* "Menu") (set_tile "mMenu" "1")) ((= *glfs-mode* "Auto") (set_tile "mAuto" "1")) (T (set_tile "mDraw" "1")) ) (set_tile "optZoom" (if *glfs-zoom* "1" "0")) (set_tile "optProgress" (if *glfs-progress* "1" "0")) (action_tile "accept" "(setq mode (cond ((= (get_tile \"mMenu\") \"1\") \"Menu\") ((= (get_tile \"mAuto\") \"1\") \"Auto\") (T \"Drawing\"))) (setq zoom (= (get_tile \"optZoom\") \"1\")) (setq progress (= (get_tile \"optProgress\") \"1\")) (done_dialog 1)") (action_tile "cancel" "(done_dialog 0)") (setq dclReturn (start_dialog)) (unload_dialog dclId) (if (= dclReturn 1) (progn (setq *glfs-mode* mode) (setq *glfs-zoom* zoom) (setq *glfs-progress* progress) (list mode zoom progress)) nil)))))))) ;;; =========================================================================== ;;; MAIN COMMAND ;;; =========================================================================== (defun c:GLFS ( / acadObj docObj msObj surfSel surfMenu objName sName ent obj choice surfEnt sset pts i k m item idx oldCmd oldOsm oldOsnap oldDyn oldBlip oldHigh oldRegen oldNomutt n pt single batchSize chunk j totalProcessed res selMode doZoom doProgress ) (vl-load-com) ;; --- Cache & silence env for raw speed --- (setq oldCmd (getvar "CMDECHO") oldOsm (getvar "OSMODE") oldOsnap (getvar "OSNAPCOORD") oldDyn (getvar "DYNMODE") oldBlip (getvar "BLIPMODE") oldHigh (getvar "HIGHLIGHT") oldRegen (getvar "REGENMODE") oldNomutt (getvar "NOMUTT")) (setvar "CMDECHO" 0) (setvar "OSMODE" 0) (setvar "OSNAPCOORD" 1) (setvar "DYNMODE" 0) (setvar "BLIPMODE" 0) (setvar "HIGHLIGHT" 0) (setvar "REGENMODE" 0) (setvar "NOMUTT" 0) (setq acadObj (vlax-get-acad-object) docObj (vla-get-activedocument acadObj) msObj (vla-get-modelspace docObj)) ;; --- Pre-scan surfaces --- (setq surfMenu '()) (vlax-for obj msObj (setq objName (vl-catch-all-apply 'vla-get-objectname (list obj))) (if (and (not (vl-catch-all-error-p objName)) objName (wcmatch (strcase objName) "*AECC*SURFACE*")) (progn (setq sName (vl-catch-all-apply 'vla-get-name (list obj)) ent (vl-catch-all-apply 'vlax-vla-object->ename (list obj))) (if (and (not (vl-catch-all-error-p sName)) (not (vl-catch-all-error-p ent)) sName ent) (setq surfMenu (cons (list sName ent) surfMenu)))))) (setq surfEnt nil) (setq single (= (length surfMenu) 1)) (cond ;; ---------- No surfaces ---------- ((= (length surfMenu) 0) (princ "\nError: No valid Civil 3D Surfaces found in the drawing.")) ;; ---------- Popup menu ---------- (t (setq res (GLFS:ShowMenu)) (if res (progn (setq selMode (nth 0 res) doZoom (nth 1 res) doProgress (nth 2 res))) ;; Fallback to keyboard if dialog cancelled (progn (princ "\n\n--- SURFACE SELECTION MODES ---") (princ "\n[Drawing] Pick the surface directly from the drawing") (princ "\n[Menu] Select from numbered surface list") (princ "\n[Auto] Auto (only if a single surface exists)") (princ "\n--------------------------------") (initget "Drawing Menu Auto") (setq selMode (getkword (strcat "\nChoose surface mode [Drawing/Menu/Auto] <" *glfs-mode* ">: "))) (if (null selMode) (setq selMode *glfs-mode*)) (setq *glfs-mode* selMode) (setq doZoom *glfs-zoom*) (setq doProgress *glfs-progress*))) (cond ;; ---- AUTO - only valid when exactly one surface ---- ((= selMode "Auto") (if single (setq surfEnt (cadr (car surfMenu))) (progn (princ "\nAuto mode requires exactly one surface. Falling back to Menu.") (setq selMode "Menu")))) (T nil)) (cond ;; ---- MENU ---- ((= selMode "Menu") (setq surfMenu (vl-sort surfMenu '(lambda (a b) (< (strcase (car a)) (strcase (car b)))))) (princ "\n\n--- AVAILABLE CIVIL 3D SURFACES ---") (setq idx 1) (foreach item surfMenu (princ (strcat "\n[" (itoa idx) "] " (car item))) (setq idx (1+ idx))) (princ "\n------------------------------------") (initget 1) (if single (setq choice 1) (setq choice (getint (strcat "\nEnter surface number [1-" (itoa (length surfMenu)) "]: ")))) (if (and choice (>= choice 1) (<= choice (length surfMenu))) (setq surfEnt (cadr (nth (1- choice) surfMenu))))) ;; ---- DRAWING ---- ((= selMode "Drawing") (setq surfSel (entsel "\nPick surface from drawing: ")) (if surfSel (progn (setq ent (car surfSel) obj (vl-catch-all-apply 'vlax-ename->vla-object (list ent))) (if (and (not (vl-catch-all-error-p obj)) (not (vl-catch-all-error-p (setq objName (vl-catch-all-apply 'vla-get-objectname (list obj))))) objName (wcmatch (strcase objName) "*AECC*SURFACE*")) (setq surfEnt ent) (princ "\nError: Selected object is NOT a valid Civil 3D Surface."))))) (T nil))) ) ;; --- Label engine --- (if surfEnt (progn (setq sName (vl-catch-all-apply 'vla-get-name (list (vlax-ename->vla-object surfEnt)))) (if (vl-catch-all-error-p sName) (setq sName "Selected Surface")) (princ (strcat "\nTarget Surface Locked: " sName)) (setvar "NOMUTT" 1) (princ "\nSelect AutoCAD Points to label (Window/Crossing): ") (setq sset (ssget '((0 . "POINT")))) (if sset (progn (setq n (sslength sset) pts '()) (princ (strcat "\nProcessing " (itoa n) " labels in batches... Please wait...")) ;; Extract all coordinates (setq i 0) (repeat n (setq k (ssname sset i) m (cdr (assoc 10 (entget k))) pts (cons m pts)) (setq i (1+ i))) (setq pts (reverse pts)) ;; Optional zoom (if doZoom (command "_.zoom" "_object" sset "")) (vla-startundomark docObj) ;; --- PULSED BATCHING ENGINE --- (setq batchSize 1021) (setq totalProcessed 0) (while pts (setq chunk '() j 0) (while (and pts (< j batchSize)) (setq chunk (cons (car pts) chunk) pts (cdr pts) j (1+ j))) (setq chunk (reverse chunk)) (foreach pt chunk (if (= 0 (logand 1 (getvar "CMDACTIVE"))) (if single (command "._ADDSURFACESPOTELEVLABEL" "_non" pt) (command "._ADDSURFACESPOTELEVLABEL" (list surfEnt pt) "_non" pt) ) (command "_non" pt) ) ) (while (> (logand 1 (getvar "CMDACTIVE")) 0) (command "") ) (setq totalProcessed (+ totalProcessed (length chunk))) (if doProgress (princ (strcat "\n... Built " (itoa totalProcessed) " of " (itoa n) " ..."))) ) (vla-endundomark docObj) (if doZoom (command "_.zoom" "_previous")) (princ (strcat "\nFinished! " (itoa n) " labels processed successfully."))) (princ "\nNo points selected.")))) ;; --- Restore env --- (setvar "REGENMODE" oldRegen) (setvar "NOMUTT" oldNomutt) (setvar "HIGHLIGHT" oldHigh) (setvar "BLIPMODE" oldBlip) (setvar "DYNMODE" oldDyn) (setvar "OSNAPCOORD" oldOsnap) (setvar "OSMODE" oldOsm) (setvar "CMDECHO" oldCmd) (princ) ) (princ "\nGLFS Loaded (safe DCL, radio + toggle ticks).") (princ)