Leaderboard

(Defun c:PSS (/ _WriteDataToExcel _SOrtThis chainColl levelColl ChainAndLevels comments chainColl levelColl crossing crossingString ) ;;; pBe Oct. 2020 ;;; (Defun _WriteDataToExcel (tmpl lst / newDataFile) (if (and tmpl (setq newDataFile (getfiled "Enter New Data file" (strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) ".xlsx" ) "xlsx;xls" 1 ) ) gc:WriteExcel ) (progn (vl-file-delete newDataFile) (vl-file-copy tmpl newDataFile) (gc:WriteExcel newDataFile "Sheet1" "A3" lst) ) ) (princ (strcat "\nData saved : " newDataFile)) ) (Defun _SOrtThis (l) (mapcar 'cdr (vl-sort l '(lambda (a b) (< (car a) (car b)))) ) ) (princ "\nSelect LEVELS and CHAINAGE") (if (and gc:WriteExcel ;;<-- gc:WriteExcel should be loaded (or XcelTemplate (setq XcelTemplate (getfiled "Select Template file" (getvar 'dwgprefix) "xlsx;xls" 16 ) ) ) (setq ChainAndLevels (ssget '((0 . "TEXT") (1 . "*#.#*")))) ) (progn (repeat (setq i (sslength ChainAndLevels)) (setq ent (entget (ssname ChainAndLevels (setq i (1- i))))) (setq data (cons (cadr (assoc 10 ent)) (cdr (assoc 1 ent)) ) ) (if (vl-string-position 43 (Cdr data)) (Setq chainColl (cons data chainColl)) (setq levelColl (cons data levelColl)) ) ) (setq ChainAndLevels (mapcar 'list (_SOrtThis chainColl) (_SOrtThis levelColl) ) ChainAndLevels (mapcar '(lambda (v) (list (Car v) (distof (Cadr v))) ) ChainAndLevels ) ) (princ "\nSelect Crossings[Enter for none]") (if (setq crossing (ssget '((0 . "TEXT") (1 . "*#+#*")))) (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex crossing)) ) (setq crossingString (getpropertyvalue itm "TextString")) (if (setq found (vl-some '(lambda (cl) (if (vl-string-search (Car cl) crossingString) cl ) ) ChainAndLevels ) ) (setq ChainAndLevels (subst (append found (list crossingString)) found ChainAndLevels ) ) ) ) ) ;;; Commented ;;; (foreach itm ChainAndLevels (print itm) ) ;;; Writing data to excel File ;;; (_WriteDataToExcel XcelTemplate ChainAndLevels) ;;; ;;; ) (Vl-some '(lambda (d) (if (not (eval (Car d))) (princ (strcat "\n" (cadr d) " not found")) ) ) '((gc:WriteExcel "WriteExcel function") (XcelTemplate "Data Template") (ChainAndLevels "Chainage and Levels data") ) ) ) (princ) ) ;;------------------------------------------------------------------------------- ;; gc:WriteExcel ;; Writes in an Excel file ;; ;; Arguments : 4 ;; filename : complete path of the file ;; sheet : name of the sheet (or nil for the current sheet) ;; startRange : name of the start cell (or nil for "A1") ;; dataList : list of sub-lists containing the data (one sub-list per row) ;;------------------------------------------------------------------------------- (defun gc:WriteExcel (filename sheet startRange dataList / *error* xlApp wBook save sheets active start row col cells n cell ) (vl-load-com) (defun *error* (msg) (and msg (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (and wBook (vlax-invoke-method wBook 'Close :vlax-False)) (and xlApp (vlax-invoke-method xlApp 'Quit)) (and reg (vlax-release-object reg)) (mapcar (function (lambda (obj) (and obj (vlax-release-object obj)))) (list cell cells wBook xlApp) ) (gc) ) (setq xlapp (vlax-get-or-create-object "Excel.Application")) (if (findfile filename) (setq wBook (vlax-invoke-method (vlax-get-property xlapp 'WorkBooks) 'Open filename) save T ) (setq wBook (vlax-invoke-method (vlax-get-property xlapp 'WorkBooks) 'Add)) ) (if sheet (progn (setq sheets (vlax-get-property xlApp 'Sheets)) (vlax-for s sheets (if (= (strcase (vlax-get-property s 'Name)) (strcase sheet)) (progn (vlax-invoke-method s 'Activate) (setq active T) ) ) ) (or active (vlax-put-property (vlax-invoke-method sheets 'Add) 'Name sheet) ) ) ) (if startRange (setq start (gc:ColumnRow startRange) col (car start) row (cadr start) ) (setq col 1 row 1 ) ) (setq cells (vlax-get-property xlApp 'Cells)) (or startRange (vlax-invoke-method cells 'Clear)) (foreach sub dataList (setq n col) (foreach data sub (setq cell (vlax-variant-value (vlax-get-property cells 'Item row n))) (if (= (type data) 'STR) (vlax-put-property cell 'NumberFormat "@") ) (vlax-put-property cell 'Value2 data) (setq n (1+ n)) ) (setq row (1+ row)) ) (vlax-invoke-method (vlax-get-property (vlax-get-property xlApp 'ActiveSheet) 'Columns ) 'AutoFit ) (if save (vlax-invoke-method wBook 'Save) (if (and (< "11.0" (vlax-get-property xlapp "Version")) (= (strcase (vl-filename-extension filename) T) ".xlsx") ) (vlax-invoke-method wBook 'SaveAs filename 51 "" "" :vlax-false :vlax-false 1 1) (vlax-invoke-method wBook 'SaveAs filename -4143 "" "" :vlax-false :vlax-false 1 1) ) ) (*error* nil) ) ;;------------------------------------------------------------------------------- ;; gc:ReadExcel ;; Returns a list of sub-lists containing the data of an Excel file (one sub-list per row) ;; ;; Arguments : 4 ;; filename : complete path of the file ;; sheet : name of the sheet (or nil for the current sheet) ;; startRange : name of the start cell (or nil for "A1") ;; maxRange : name of the cell where the reading have to stop, ;; or "*" for the whole sheet, or nil or "" for the current range ;;------------------------------------------------------------------------------- (defun gc:ReadExcel (filename sheet startRange maxRange / *error* xlApp wBook wSheet startCell startCol startRow maxCell maxCol maxRow reg cells col row data sub lst ) (defun *error* (msg) (and msg (/= msg "Fonction annulée") (princ (strcat "\nErreur: " msg)) ) (and wBook (vlax-invoke-method wBook 'Close :vlax-False)) (and xlApp (vlax-invoke-method xlApp 'Quit)) (mapcar (function (lambda (obj) (and obj (vlax-release-object obj)))) (list reg cells wSheet wBook xlApp) ) (gc) ) (setq xlapp (vlax-get-or-create-object "Excel.Application") wBook (vlax-invoke-method (vlax-get-property xlApp 'WorkBooks) 'Open filename) ) (if sheet (vlax-for ws (vlax-get-property xlapp 'Sheets) (if (= (vlax-get-property ws 'Name) sheet) (vlax-invoke-method (setq wSheet ws) 'Activate) ) ) (setq wSheet (vlax-get-property wBook 'ActiveSheet)) ) (if startRange (setq startCell (gc:ColumnRow startRange) startCol (car startCell) startRow (cadr startCell) ) (setq startRange "A1" startCol 1 startRow 1 ) ) (if (and maxRange (setq maxCell (gc:ColumnRow maxRange))) (setq maxCol (1+ (car MaxCell)) maxRow (1+ (cadr MaxCell)) ) (setq reg (if (= maxRange "*") (vlax-get-property wSheet 'UsedRange) (vlax-get-property (vlax-get-property wSheet 'Range startRange) 'CurrentRegion ) ) maxRow (+ (vlax-get-property reg 'Row) (vlax-get-property (vlax-get-property reg 'Rows) 'Count) ) maxCol (+ (vlax-get-property reg 'Column) (vlax-get-property (vlax-get-property reg 'Columns) 'Count) ) ) ) (setq cells (vlax-get-property xlApp 'Cells) row maxRow ) (while (< startRow row) (setq sub nil col maxCol row (1- row) ) (while (< startCol col) (setq col (1- col) sub (cons (vlax-variant-value (vlax-get-Property (vlax-variant-value (vlax-get-property cells 'Item row col)) 'Value2 ) ) sub ) ) ) (setq lst (cons sub lst)) ) (*error* nil) lst ) ;;------------------------------------------------------------------------------- ;; gc:ColumnRow ;; Returns a list of the column row indices ;; Argument: 1 ;; cell = name of the cell ;; Using example : (gc:ColumnRow "IV987") -> (256 987) ;;------------------------------------------------------------------------------- (defun gc:ColumnRow (cell / col char row) (setq col "") (while (< 64 (ascii (setq char (strcase (substr cell 1 1)))) 91) (setq col (strcat col char) cell (substr cell 2) ) ) (if (and (/= col "") (numberp (setq row (read Cell)))) (list (gc:Alpha2Number col) row) ) ) ;;------------------------------------------------------------------------------- ;; gc:Alpha2Number ;; Converts a string into an integer ;; Arguments: 1 ;; str = string to convert ;; Using example : (gc:Alpha2Number "BU") = 73 ;;------------------------------------------------------------------------------- (defun gc:Alpha2Number (str / num) (if (= 0 (setq num (strlen str))) 0 (+ (* (- (ascii (strcase (substr str 1 1))) 64) (expt 26 (1- num)) ) (gc:Alpha2Number (substr str 2)) ) ) ) ;;------------------------------------------------------------------------------- ;; gc:Number2Alpha - Convertit un nombre entier en chaîne alphabétique ;; Converts an integer into a string ;; Arguments: 1 ;; num = integer to convert ;; Using example : (gc:Number2Alpha 73) = "BU" ;;------------------------------------------------------------------------------- (defun gc:Number2Alpha (num / val) (if (< num 27) (chr (+ 64 num)) (if (= 0 (setq val (rem num 26))) (strcat (gc:Number2Alpha (1- (/ num 26))) "Z") (strcat (gc:Number2Alpha (/ num 26)) (chr (+ 64 val))) ) ) )