坐标提取lisp程序

坐标提取lisp程序2010-05-17 20:50:07| 分类：工程| 标签：|字号大中小订阅;该程序主要用于CAD点（point）三维坐标提取，并将数据输出为CASS软件中使用的数据格式;输出格式：点号,,测量Y值，测量X值，测量Z值例：1,,100.3244,1232,433,25;2010-05-17;命令：plzbsc(defun c:plzbsc()(princ "\n选择所需输出的点（point）:")(setq ss (ssget ));;选取坐标点(setq n (sslength ss ));计算坐标点数量(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w"));保存路径(setq i 0)(repeat n(setq spt (ssname ss i ))(setq ept (entget spt))(if (= (cdr (assoc 0 ept)) "POINT")(progn(setq lxyz (cdr (assoc 10 ept)))(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符(setq sy (rtos (nth 0 lxyz)))(setq sz (rtos (nth 2 lxyz)))(setq i1 (+ i 1));计算点序号(setq sn (rtos i1 2 0));将序号实数转换成字符(setq sxyz (strcat sn",," sy "," sx "," sz))(write-line sxyz ff)))(setq i (+ i 1)));repeat)(prompt "* << 命令:plzbsc >> *输出格式（点号,, Y，X，Z）**")(prin1)地形图上提取碎步点（高程点）坐标并输出到文本2010-05-18 08:50:38| 分类：工程| 标签：|字号大中小订阅利用程序提取地形图上碎步点的三维坐标。

并输出到记事本中，该程序待修改的地方是不能选取点，并输出数据，待改正。

(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq en (entsel "选择高程点:")) ;要求碰选一个高程点(setq ff (open (getfiled "文件保存为" "f:/" "txt" 1) "a"))(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py(rtos (nth 1 pt)));提取测量坐标Y值(setq px(rtos (nth 0 pt)));提取测量坐标X值(setq pz(rtos (nth 2 pt)));提取测量坐标Z值(setq sxyz (strcat px " " py " " pz))(write-line sxyz ff)(prin1))(prompt "*************** << C:gcdtq >> *****************")(prin1)连续选取高程点并输出到文本2010-05-18 15:33:49| 分类：工程| 标签：|字号大中小订阅;2010-05-18 武赤公路;用于提取地形图中的高程点（碎步点）坐标，同时可以提取点（point）的坐标;本程序的缺点是不能过滤对象，同时也成为了他的优点；没有限制点的样式，块也可以，点也可以；;本程序设计保存文件是可以在已有文件中继续添加数据，但是序号不再累积；这样可以判断不同时期选取的数据(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "a"))(setq en (entsel "选择高程点:"));要求碰选一个高程点(setq i 1);生成序号(while en(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py(rtos (nth 1 pt)));提取测量坐标系Y值(setq px(rtos (nth 0 pt)));提取测量坐标洗X值(setq pz(rtos (nth 2 pt)));提取测量坐标系Z值(setq pi(rtos i 2 0))(setq pxyz (strcat pi",," px "," py "," pz));输出为CASS数据格式(write-line pxyz ff);写入文本(setq en (entsel "\n选择下一个高程点<回车结束选择>:"))(setq i (+ i 1)))(close file)(prin1))(prompt "**从CASS中提取高程点或（point）点坐标，* << C:gcdtq >> *高程点提取**") (prin1)横断面数据提取（待修改）2010-05-18 21:59:09| 分类：工程| 标签：|字号大中小订阅(defun c:hdm()(setvar "cmdecho" 0) ;指令执行过程不响应;计算方位角(setq ff (open (getfiled "文件保存为" "c:/" "hdm" 1) "a"))(setq zh (getreal"请输入桩号："));计算横断面上点到中心线的垂距，数值分正负(setq pt1 (getpoint "\n拾取纵断面上的一点："));用于确定横断面上的零点位置(setq x1 (car pt1));给纵断面上一点X赋值x1(setq y1 (cadr pt1));给纵断面上一点Y赋值y1(setq pt2 (getpoint "\n拾取纵断面上的第二点："));用于确定横断面上的零点位置(setq x2 (car pt2));给纵断面上一点X赋值x1(setq y2 (cadr pt2));给纵断面上一点Y赋值y1;计算纵断面（pt1->pt2）方位角(setq j1 (atan (/(- y2 y1) (+(- x2 x1) 0.00000001)))))(setq j2 (/(* j1 180) pi))(if (>(- y2 y1) 0)(setq sgn 1));符号判断(if (=(- y2 y1) 0)(setq sgn 0))(if (<(- y2 y1) 0)(setq sgn -1))(setq fwj (+ (- 180(* 90 sgn) j2)));方位角计算(setq ang (/(* fwj pi) 180))(setq en (entsel "选择高程点:"));要求碰选一个高程点(while en(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py (nth 1 pt));提取测量坐标系Y值(setq px (nth 0 pt));提取测量坐标洗X值(setq px2 (sin ang))(setq px3 (cos ang))(setq cj (-(* (- py y1) (cos ang)) (* (- px x1) (sin ang))));计算垂直距离（cj）(setq dist (rtos cj 2 0))(setq pz(rtos (nth 2 pt)));提取测量坐标系Z值(setq pdz (strcat dist","pz));输出为CASS数据格式(write-line pdz ff);写入文本(setq en (entsel "\n选择下一个高程点<回车结束选择>:")))(close file)(prin1))(prompt "**从CASS中提取高程点或（point）点坐标，* << C:hdm >> *输出横断面数据（平距，高程）**") (prin1)批量提取CAD中点（point）三维坐标2010-05-22 23:11:43| 分类：默认分类| 标签：|字号大中小订阅;该程序主要用于CAD点（point）三维坐标提取，并将数据输出为CASS软件中使用的数据格式;输出格式：点号,,测量Y值，测量X值，测量Z值例：1,,100.3244,1232,433,25;2010-05-17 罗泽钢中国葛洲坝集团基础工程有限公司;命令：plzbsc(defun c:plzbsc()(princ "\n选择所需输出的点（point）:")(setq ss (ssget ));;选取坐标点(setq n (sslength ss ));计算坐标点数量(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w"));保存路径(setq i 0)(repeat n(setq spt (ssname ss i ))(setq ept (entget spt))(if (= (cdr (assoc 0 ept)) "POINT")(progn(setq lxyz (cdr (assoc 10 ept)))(setq sx (rtos (nth 1 lxyz)));将坐标值实数转换成字符(setq sy (rtos (nth 0 lxyz)))(setq sz (rtos (nth 2 lxyz)))(setq i1 (+ i 1));计算点序号(setq sn (rtos i1 2 0));将序号实数转换成字符(setq sxyz (strcat sn",," sy "," sx "," sz))(write-line sxyz ff)))(setq i (+ i 1)));repeat)(prompt "*只适合point点<< 命令:plzbsc >> *输出格式（点号,, Y，X，Z）**") (prin1)从CASS提取高程点坐标输出到文本2010-05-22 23:15:18| 分类：工程| 标签：高程点提取 cass |字号大中小订阅:2010-05-17(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq en (entsel "选择高程点:")) ;要求碰选一个高程点(setq ff (open (getfiled "文件保存为" "f:/" "txt" 1) "a"))(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py(rtos (nth 1 pt)));提取测量坐标Y值(setq px(rtos (nth 0 pt)));提取测量坐标X值(setq pz(rtos (nth 2 pt)));提取测量坐标Z值(setq sxyz (strcat px " " py " " pz))(write-line sxyz ff)(prin1))(prompt "*************** << C:gcdtq >> *****************")(prin1);修改后可以实现连续提取2011--02--25(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "a"))(setq n 0)(while;循环语句(setq en (entsel "\n 选择高程点:")) ;要求碰选一个高程点(redraw (car en) 3);亮显高程点(setq n(+ n 1))(setq pn(rtos n 2 0))(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py(rtos (nth 1 pt)));提取测量坐标Y值(setq px(rtos (nth 0 pt)));提取测量坐标X值(setq pz(rtos (nth 2 pt)));提取测量坐标Z值(setq sxyz (strcat pn",,"px "," py "," pz))(write-line sxyz ff)(prin1)(princ sxyz)))(prompt "***** << C:gcdtq >> ***提取高程点输出为CASS格式****")(prin1);VLISP与EXCEL之间连接及数据传输和函数集2011-05-29 08:35:14| 分类：工程| 标签：|字号大中小订阅;;;*************************************************************************;;;;;; DSX-API-Excel.LSP ;;;;;; Visual LISP ActiveX API for Excel 97, 2000 and XP ;;;;;; Copyright (C)2002 David M. Stein, All rights reserved ;;;;;;*************************************************************************;;;;;; Version 2002.22 05/15/02: Initial release ;;;;;;*************************************************************************;;;;;; Code provided AS-IS without warranty of any kind given for any purpose ;;; ;;; or use, either explicitly, implicitly or as a derivative work item. ;;;;;; User assumes ANY AND ALL RISK and LIABILITY for use of any of this code ;;;;;; for any consequential damages of any kind. These functions are defined ;;; ;;; within DSX Tools 2002.22 when loaded into AutoCAD. This document is ;;;;;; provided for informational purposes only. ;;;;;;*************************************************************************;;;(vl-load-com);;;*************************************************************************;;; MODULE: DSX-TypeLib-Excel;;; DEs criptION: Returns typelib (olb) file for either Excel 97, 2000, or XP ;;; ARGS: none;;; EXAMPLE: (DSX-TypeLib-Excel);;;*************************************************************************(defun DSX-TypeLib-Excel ( / sysdrv tlb)(setq sysdrv (getenv "systemdrive"))(cond( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel8.olb")))tlb)( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel9.olb")))tlb)( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel10.olb")))tlb)( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel.exe")))tlb)( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office10\\Excel.exe")))tlb)));;;*************************************************************************;;; MODULE: DSX-Load-TypeLib-Excel;;; DEs criptION: Loads typelib for Excel 97, 2000 or XP (whichever is found) ;;; ARGS: none;;; EXAMPLE: (DSX-Load-TypeLib-Excel);;;*************************************************************************(defun DSX-Load-TypeLib-Excel ( / tlbfile tlbver out)(dsx-princ "\n(DSX-Load-TypeLib-Excel)")(cond( (null msxl-xl24HourClock)(if (setq tlbfile (DSX-TypeLib-Excel))(progn(setq tlbver (substr (vl-filename-base tlbfile) 6))(cond( (= tlbver "9") (princ "\nInitializing Microsoft Excel 2000...") )( (= tlbver "8") (princ "\nInitializing Microsoft Excel 97...") )( (= (vl-filename-base tlbfile) "Excel.exe")(princ "\nInitializing Microsoft Excel XP...")))(vlax-import-type-library:tlb-filename tlbfile:methods-prefix "msxl-":properties-prefix "msxl-":constants-prefix "msxl-")(if msxl-xl24HourClock (setq out T)))))( T (setq out T) ))out);;;************************************************************************* ;;; MODULE: DSX-Open-Excel-New;;; DEs criptION: Opens a new session of Excel 97, 2000 or XP ;;; ARGS: display-mode ("SHOW" or "HIDE");;; EXAMPLE: (setq xlapp (DSX-Open-Excel-New "SHOW")) ;;;************************************************************************* (defun DSX-Open-Excel-New (dmode / appsession)(dsx-princ "\n(DSX-Open-Excel-New)")(princ "\nCreating new Excel Spreadsheet file...")(cond( (setq appsession (vlax-create-object "Excel.Application")) (vlax-invoke-method(vlax-get-property appsession 'WorkBooks)'Add)(if (= (strcase dmode) "SHOW")(vla-put-visible appsession 1)(vla-put-visible appsession 0))))appsession);;;*************************************************************************;;; MODULE: DSX-Open-Excel-Exist;;; DEs criptION: Gets handle to existing (running) session of Excel 97, 2000, XP;;; ARGS: xls-filename, display-mode ("SHOW" or "HIDE");;; EXAMPLE: (setq xlapp (DSX-Open-Excel-Exist "myfile.xls" "SHOW")) ;;;*************************************************************************(defun DSX-Open-Excel-Exist (xfile dmode / appsession)(dsx-princ "\n(DSX-Open-Excel-Exist)")(princ "\nOpening Excel Spreadsheet file...")(cond( (setq fn (findfile xfile))(cond( (setq appsession (vlax-get-or-create-object "Excel.Application")) (vlax-invoke-method(vlax-get-property appsession 'WorkBooks)'Open fn)(if (= (strcase dmode) "SHOW")(vla-put-visible appsession 1)(vla-put-visible appsession 0)))))( T (alert (strcat "\nCannot locate source file: " xfile)) ))appsession);;;*************************************************************************;;; MODULE: DSX-Excel-Put-ColumnList;;; DEs criptION: Write each list member to a column (startcol) starting at row (startrow);;; ARGS: list, startrow, startcol;;; EXAMPLE: (DSX-Excel-Put-ColumnList '("A" "B" "C") 1 2) puts members into cells (1,B) (2,B) (3,B) respectively;;;*************************************************************************(defun DSX-Excel-Put-ColumnList (lst startrow startcol)(dsx-princ "\n(DSX-Excel-Put-ColumnList)")(foreach itm lst(msxl-put-value(DSX-Excel-Get-Cell range startrow startcol)itm)(setq startrow (1+ startrow))); repeat);;;*************************************************************************;;; MODULE: DSX-Excel-Put-RowList;;; DEs criptION: Write each list member to row (startrow) starting at column (startcol);;; ARGS: list, startrow, startcol;;; EXAMPLE: (DSX-Excel-Put-RowList '("A" "B" "C") 2 1) puts members into cells (1,B) (1,C) (1,D) respectively;;;*************************************************************************(defun DSX-Excel-Put-RowList (lst startrow startcol)(dsx-princ "\n(DSX-Excel-Put-RowList)")(foreach itm lst(msxl-put-value(DSX-Excel-Get-Cell range startrow startcol)itm)(setq startcol (1+ startcol))); repeat);;;*************************************************************************;;; MODULE: DSX-Excel-Put-CellColor;;; DEs criptION: Applies fill-color to specified cell;;; ARGS: row, column, color (integer);;; EXAMPLE: (DSX-Excel-Put-CellColor 1 1 14) apply color #14 to cell (1,A) ;;;*************************************************************************(defun DSX-Excel-Put-CellColor (row col intcol / rng)(setq rng (DSX-Excel-Get-Cell (msxl-get-ActiveSheet xlapp) row col)) (msxl-put-colorindex (msxl-get-interior rng) intcol));;;*************************************************************************;;; MODULE: DSX-Excel-Put-RowCellsColor;;; DEs criptION: Applies fill-color to a row of cells;;; ARGS: startrow, startcol, num-cols, color (integer);;; EXAMPLE: (DSX-Excel-Put-RowCellsColor 1 1 5 14) Start at row=1 col=1 repeat for 5 columns using color #14;;;*************************************************************************(defun DSX-Excel-Put-RowCellsColor(startrow startcol cols intcol / next)(dsx-princ "\n(DSX-Excel-Put-RowCellsColor)")(setq next startcol)(repeat cols(DSX-Excel-Put-CellColor startrow next intcol)(setq next (1+ next))));;;*************************************************************************;;; MODULE: DSX-Excel-Put-ColumnCellsColor;;; DEs criptION: Change fill color in a column of cells;;; ARGS: startrow, startcol, num-rows, color (integer);;; EXAMPLE: (DSX-Excel-Put-ColumnCellsColor 1 1 5 14) Start at row=1 col=1 repeat for 5 rows using color #14;;;*************************************************************************(defun DSX-Excel-Put-ColumnCellsColor(startrow startcol rows intcol / next)(dsx-princ "\n(DSX-Excel-Put-ColumnCellsColor)")(setq next startrow)(repeat rows(DSX-Excel-Put-CellColor next startcol intcol)(setq next (1+ next))));;;*************************************************************************;;; MODULE: DSX-Excel-Get-Cell;;; DEs criptION: Get cell object relative to range using (relrow) and (relcol) offsets;;; ARGS: range-object, relative-row, relative-col;;; EXAMPLE: (DSX-Excel-Get-Cell rng1 2 2);;;*************************************************************************(defun DSX-Excel-Get-Cell (rng relrow relcol)(dsx-princ "\n(DSX-Excel-Get-Cell)")(vlax-variant-value(msxl-get-item (msxl-get-cells rng)(vlax-make-variant relrow)(vlax-make-variant relcol))));;;*************************************************************************;;; MODULE: DSX-Excel-Get-CellValue;;; DEs criptION: Return value in given cell (row, column) of active session object (xlapp);;; ARGS: row(int), column(int);;; EXAMPLE: (DSX-Excel-Get-CellValue 1 2);;;*************************************************************************(defun DSX-Excel-Get-CellValue (row col)(dsx-princ "\n(DSX-Excel-Get-CellValue)")(vlax-variant-value(msxl-get-value(DSX-Excel-Get-Cell(msxl-get-ActiveSheet xlapp)row col))));;;*************************************************************************;;; MODULE: DSX-Excel-Get-RowValues;;; DEs criptION: Returns a list of cell values within a given row;;; ARGS: row-number(int), startcol, num-cells;;; EXAMPLE: (DSX-Excel-Get-RowValues 3 1 20) get first 20 values in row 3 ;;;*************************************************************************(defun DSX-Excel-Get-RowValues(row startcol numcells / next out)(dsx-princ "\n(DSX-Excel-Get-RowValues)")(setq next startcol)(repeat numcells(setq out (if out(append out (list (DSX-Excel-Get-CellValue row next))); row x col(list (DSX-Excel-Get-CellValue row next)); row x col)next (1+ next))); repeatout);;;*************************************************************************;;; MODULE: DSX-Excel-Get-ColumnValues;;; DEs criptION: Returns a list of cell values within a given column;;; ARGS: column-number(int), startrow, num-cells;;; EXAMPLE: (DSX-Excel-Get-ColumnValues 2 1 20) get top-20 entries in column 2 ("B");;;*************************************************************************(defun DSX-Excel-Get-ColumnValues(col startrow numcells / next out)(dsx-princ "\n(DSX-Excel-Get-ColumnValues)")(setq next startrow)(repeat numcells(setq out(if out(append out (list (DSX-Excel-Get-CellValue next col)))(list (DSX-Excel-Get-CellValue next col)))next (1+ next))); repeatout);;;*************************************************************************;;; MODULE: DSX-Excel-GetRangeValues-ByRows;;; DEs criptION: Get range values in row order and return as nested lists ;;; ARGS: startrow, startcol, num-rows, num-cols;;; EXAMPLE: (DSX-Excel-GetRangeValues-ByRows 1 1 5 10) get range values from 1A to 5J where each sublist is one row;;;*************************************************************************(defun DSX-Excel-GetRangeValues-ByRows(startrow startcol numrows numcols / nextrow rowlst outlst)(dsx-princ "\n(DSX-Excel-GetRangeValues-ByRows)")(setq nextrow startrow)(repeat numrows(setq rowlst (DSX-Excel-Get-RowValues nextrow startcol numcols)outlst (if outlst (append outlst (list rowlst)) (list rowlst))nextrow (1+ nextrow)))outlst);;;*************************************************************************;;; MODULE: DSX-Excel-GetRangeValues-ByCols;;; DEs criptION: Get range values in column order and return as nested lists ;;; ARGS: startrow, startcol, num-rows, num-cols;;; EXAMPLE: (DSX-Excel-GetRangeValues-ByCols 1 1 5 10) get range values from 1A to 5J where each sublist is one column;;;*************************************************************************(defun DSX-Excel-GetRangeValues-ByCols(startrow startcol numrows numcols / nextrow nextcol collst outlst)(dsx-princ "\n(DSX-Excel-GetRangeValues-ByCols)")(setq nextcol startcol)(repeat numcols(setq collst (DSX-Excel-Get-ColumnValues nextcol startrow numrows) outlst (if outlst (append outlst (list collst)) (list collst))nextcol (1+ nextcol)))outlst);;;*************************************************************************;;; MODULE: DSX-Excel-Get-ActiveWorkSheet;;; DEs criptION: Returns object of active worksheet in active Excel session ;;; ARGS: app (session object);;; EXAMPLE: (DSX-Excel-Get-ActiveWorkSheet xlapp);;;*************************************************************************(defun DSX-Excel-Get-ActiveWorkSheet (xlapp)(dsx-princ "\n(DSX-Excel-Get-ActiveWorkSheet)")(msxl-get-ActiveSheet xlapp));;;*************************************************************************;;; MODULE: DSX-Excel-RangeAutoFit;;; DEs criptION: Applies Auto-Fit to columns within active range;;; ARGS: active-sheet (object);;; EXAMPLE: (DSX-Excel-RangeAutoFit myxlws);;;*************************************************************************(defun DSX-Excel-RangeAutoFit (active-sheet)(dsx-princ "\n(DSX-Excel-RangeAutoFit)")(vlax-invoke-method(vlax-get-property(vlax-get-property(vlax-get-property active-sheet 'UsedRange)'Cells)'Columns)'AutoFit))(defun DSX-Excel-RangeDataFormat (active-sheet)(dsx-princ "\n(DSX-Excel-RangeDataFormat)")(vlax-put-property(vlax-get-property active-sheet "Cells")'NumberFormat "@"));;;************************************************************************* ;;; MODULE: DSX-Excel-Quit;;; DEs criptION: Quit and close Excel session (app);;; ARGS: app (session object);;; EXAMPLE: (DSX-Excel-Quit xlapp);;;************************************************************************* (defun DSX-Excel-Quit (appsession)(dsx-princ "\n(DSX-Excel-Quit)")(cond( (not (vlax-object-released-p appsession))(vlax-invoke-method appsession 'QUIT)(vlax-release-object appsession))));;;************************************************************************* ;;; MODULE: DSX-Excel-Kill;;; DEs criptION: Forces any open Excel sessions to be closed ;;; ARGS: none;;; EXAMPLE: (DSX-Excel-Kill);;;************************************************************************* (defun DSX-Excel-Kill ( / eo)(while (setq eo (vlax-get-object "Excel.Application"))(DSX-Excel-Quit eo)(vlax-release-object eo)(setq eo nil)(gc)(gc);; even this doesn't always kill the damn thing!));;;************************************************************************* ;;; MODULE:;;; DEs criptION:;;; ARGS:;;; EXAMPLE:;;;************************************************************************* ;;; Remove trailing 'nil' members from a given list(defun DSX-TrimList (lst)(cond( (/= nil (last lst)) lst)( T(DSX-TrimList (reverse (cdr (reverse lst)))))));;;************************************************************************* ;;; MODULE:;;; DEs criptION:;;; ARGS:;;; EXAMPLE:;;;************************************************************************* ;;; Convert a list of values into a list of string equivalents(defun DSX-ListStr (lst / mbr out)(setq out '())(foreach mbr lst(cond( (= mbr nil) (setq out (cons "" out)) )( (= (type mbr) 'STR)(if (member mbr '(" " " " " "))(setq out (cons "" out))(setq out (cons mbr out))))( (= (type mbr) 'INT) (setq out (cons (itoa mbr) out)) )( (= (type mbr) 'REAL)(setq out (cons (rtos mbr 2 6) out)))))(reverse out));;;************************************************************************* ;;; MODULE: DSX-Excel-Sheets;;; DEs criptION: Returns SHEETS collection from active workbook ;;; ARGS: Excel-application;;; EXAMPLE: (setq sheets (DSX-Excel-Sheets xlApp));;;*************************************************************************(defun DSX-Excel-Sheets (xlapp)(setq xlsheets (vlax-get-property xlapp "sheets")));;;*************************************************************************;;; MODULE:DSX-Excel-SheetDelete;;; DEs criptION: Delete sheet (tab) from active workbook sheets collection ;;; ARG: sheet-name, sheets-collection;;; EXAMPLE: (DSX-Excel-SheetDelete "Sheet3" xlSheets);;;*************************************************************************(defun DSX-Excel-SheetDelete (name xlsheets)(vlax-for sh xlsheets(if (= (vlax-get-property sh "Name") name)(vlax-invoke-method sh "Delete"))));;;*************************************************************************;;; MODULE: DSX-Excel-SheetAdd;;; DEs criptION: Add new sheet (tab) to sheets collection in workbook, returns sheet object;;; ARG: sheet-name, sheets-collection;;; EXAMPLE: (setq newsheet (DSX-Excel-SheetAdd "SheetX" xlSheets)) ;;;*************************************************************************(defun DSX-Excel-SheetAdd (name xlsheets)(setq newsheet (vlax-invoke-method xlsheets "Add"))(vlax-put-property newsheet "Name" name)newsheet);;;*************************************************************************;;; MODULE: DSX-Excel-WorkbookSave;;; DEs criptION: Saves active workbook to specified filename, if file exists, it is overwritten if user accepts prompt;;; ARG: workbook-object, filename;;; EXAMPLE: (DSX-Excel-WorkbookSave objWB "myfile.xls");;;*************************************************************************(defun DSX-Excel-WorkbookSave (workbook filename)(if (findfile filename)(vlax-invoke-method awb "Save")(vlax-invoke-method awb "SaveAs"filename msxl-xlNormal "" "":vlax-False :vlax-False nil)));;;*************************************************************************;;; MODULE: DSX-Excel-ActiveWorkbook;;; DEs criptION: Returns active workbook object from given Excel application session;;; ARG: Excel-application;;; EXAMPLE: (setq objWB (DSX-Excel-ActiveWorkbook xlApp));;;*************************************************************************(defun DSX-Excel-ActiveWorkbook (xlapp)(vlax-get-property xlapp "ActiveWorkbook"))(princ)完美横断面数据提取程序《CAD-lisp开发》2011-01-12 18:03:20| 分类：默认分类| 标签：横断面数据提取 cass cad lisp |字号大中小订阅(defun C:hdmsj()(setvar "cmdecho" 0)(setq ff (open (getfiled "文件保存为" "c:/" "hdm" 1) "a"))(or zx(setq zx 0))(princ "\n 是否添加中线参数：<0>添加;<1>不添加:<")(princ zx)(if (setq tmp (getreal ">: "))(setq zx tmp))(ang))(defun zxcs()(setq zzh (getreal"\n请输入中桩高程："))(setq zxh (strcat "next"))(write-line zxh ff)(setq zzh0 (rtos zzh 2 3))(setq zzh1 (strcat "0,"zzh0))(write-line zzh1 ff)(setq zzh00 (rtos (- zzh 3) 2 3))(setq zzh2 (strcat "0," zzh00))(write-line zzh2 ff))(defun ang()(setq pt1 (getpoint "\n拾取纵断面上的一点："))(setq x1 (car pt1))(setq y1 (cadr pt1))(setq pt2 (getpoint "\n拾取纵断面上的第二点（道路前进方向）："))(setq x2 (car pt2))(setq y2 (cadr pt2))(setq pt11 (list y1 x1))(setq pt12 (list y2 x2))(setq ang (angle pt11 pt12))(hdm));拾取高程点进行平距计算(defun hdm()(setvar "cmdecho" 0) ;指令执行过程不响应(setq zh (getreal"\n请输入桩号："))(setq zh1 (rtos zh 2 3))(setq zh2 (strcat "BEGIN," zh1))(write-line zh2 ff)(while (setq en (entsel "\n选择高程点:"))(setvar "cmdecho" 0)(redraw (car en) 3)(setq en_data (entget (car en))) ;取得元体资料列表(setq pt (cdr (assoc 10 en_data))) ;求得高程点坐标pt(setq py (nth 0 pt));提取测量坐标系Y值(setq px (nth 1 pt));提取测量坐标洗X值(setq cj (-(* (- py x1) (cos ang)) (* (- px y1) (sin ang))));该行要注意数学坐标与测量坐标的互换计算垂直距离（cj）(setq dist (rtos cj 2 3))(setq pz(rtos (nth 2 pt)2 3));提取测量坐标系Z值(setq pdz (strcat dist","pz));输出为CASS数据格式（平距,高程）(write-line pdz ff);将数据写入文本(princ pdz))(while (/= 52 (getvar "cmdactive");(if (= zx 0)(zxcs));判断是否写入中线参数(setq xuanze (getreal"\n 1.选取下一个横断面高程点；2.选择新的切线；3.退出<1>："))(if (= xuanze nil)(hdm))(if (= xuanze 1 )(hdm))(if (= xuanze 2 ) (fwjjs))(if (= xuanze 3 )(close ff)。