Jump to content

Alignment sheet Profile Data to excel

bittu

By bittu
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

bittu Rookie

bittu

Posted
Posted

Dear User, 

                 I have 254 Alignment sheet file, i want to make List from Alignment sheet data 

as following

 

1) Chainage with Ground Level & Some Points Crossing or TP 

 

Please see Attachment

ALG Profile Data.dwg REQUIRED LIST.xlsx

hosneyalaa Community Regular

hosneyalaa

Posted
Posted 
(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)))
    )
  )
)

 

 

 

  • Like 1
bittu Rookie

bittu

Posted
  • Author
Posted
29 minutes ago, hosneyalaa said: 

(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)))
    )
  )
)

 

 

 

@hosneyalaa THANKS FOR REPLY....

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...