坐标提取lisp程序

1、精选优质文档-倾情为你奉上坐标提取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选择所需输

2、出的点（point）:")   (setq ss (ssget );选取坐标点   (setq n (sslength ss );计算坐标点数量        (setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w");保存路径   (setq i 0)   (repeat n  (setq

3、spt (ssname ss i )    (setq ept (entget spt)    (if (= (cdr (assoc 0 ept) "POINT")     (progn                        

4、60;           (setq lxyz (cdr (assoc 10  ept)       (setq sx (rtos (nth 1 lxyz);将坐标值实数转换成字符       (setq sy (rtos (nth 0 lxyz)       (setq sz (rtos (nth 2 l

5、xyz)                                        (setq i1 (+ i 1);计算点序号      

6、60;                                 (setq sn (rtos i1 2 0);将序号实数转换成字符       (setq sxyz (strcat sn","

7、  sy ","  sx  ","  sz)       (write-line sxyz ff)    )    )    (setq i (+ i 1)   );repeat )(prompt "* << 命令:plzbsc >> *输出格式（点号, Y，X，Z）*")(prin1

8、)地形图上提取碎步点（高程点）坐标并输出到文本  2010-05-18 08:50:38|  分类： |  标签： |字号大中小 订阅 利用程序提取地形图上碎步点的三维坐标。并输出到记事本中，该程序待修改的地方是不能选取点，并输出数据，待改正。(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq en (entsel "选择高程点:") ;要求碰选一个高程点(setq ff (open (getfiled "文件保存为&qu

9、ot; "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 "      &

10、#160;    "  py  "           "  pz)(write-line sxyz ff)(prin1)(prompt "* << C:gcdtq >> *")(prin1)连续选取高程点并输出到文本  2010-05-18 15:33:49|  分类： |  标签： |字号大中小

11、60;订阅 ;2010-05-18  武赤公路;用于提取地形图中的高程点（碎步点）坐标，同时可以提取点（point）的坐标;本程序的缺点是不能过滤对象，同时也成为了他的优点；没有限制点的样式，块也可以，点也可以；;本程序设计保存文件是可以在已有文件中继续添加数据，但是序号不再累积；这样可以判断不同时期选取的数据(defun c:gcdtq()(setvar "cmdecho" 0) ;指令执行过程不响应(setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) &quo

12、t;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 (str

13、cat 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)横断面数据提取（待修改）&

14、#160; 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 (

15、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.)(set

16、q 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 (a

17、ssoc 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数据格式(w

18、rite-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

19、点（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 (sslengt

20、h ss );计算坐标点数量        (setq ff (open (getfiled "文件保存为" "f:/" "dat" 1) "w");保存路径   (setq i 0)   (repeat n  (setq spt (ssname ss i )    (setq ept (entget spt)    (if (

21、= (cdr (assoc 0 ept) "POINT")     (progn                                    (setq lxyz (cdr (as

22、soc 10  ept)       (setq sx (rtos (nth 1 lxyz);将坐标值实数转换成字符       (setq sy (rtos (nth 0 lxyz)       (setq sz (rtos (nth 2 lxyz)             &

23、#160;                          (setq i1 (+ i 1);计算点序号                    &#

24、160;                   (setq sn (rtos i1 2 0);将序号实数转换成字符       (setq sxyz (strcat sn","  sy ","  sx  ","  sz)   

25、60;   (write-line sxyz ff)    )    )    (setq i (+ i 1)   );repeat )(prompt "*只适合point点 << 命令:plzbsc >> *输出格式（点号, Y，X，Z）*")(prin1)从CASS提取高程点坐标输出到文本  2010-05-22 23:15:18|  分类： | &

26、#160;标签：       |字号大中小 订阅 :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) ;

27、取得元体资料列表(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  "     

28、60;     "  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&q

29、uot;)(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 (nt

30、h 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|  分类： | 

31、0;标签： |字号大中小 订阅  *; ; DSX-API-Excel.LSP                                          

32、;             ; ; Visual LISP ActiveX API for Excel 97, 2000 and XP                       ; ; Copyright (C)2002 David M. Stein, Al

33、l rights reserved                   ; ;*; ; Version 2002.22 05/15/02: Initial release                     

34、;          ; ;*; ; 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

35、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.           

36、;                    ; ;*; (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

37、-TypeLib-Excel ( / sysdrv tlb) (setq sysdrv (getenv "systemdrive") (cond ( (setq tlb (findfile (strcat sysdrv "Program FilesMicrosoft OfficeOfficeExcel8.olb") tlb ) ( (setq tlb (findfile (strcat sysdrv "Program FilesMicrosoft OfficeOfficeExcel9.olb")   tlb ) ( (set

38、q tlb (findfile (strcat sysdrv "Program FilesMicrosoft OfficeOfficeExcel10.olb")   tlb ) ( (setq tlb (findfile (strcat sysdrv "Program FilesMicrosoft OfficeOfficeExcel.exe") tlb ) ( (setq tlb (findfile (strcat sysdrv "Program FilesMicrosoft OfficeOffice10Excel.exe"

39、)   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)&

40、quot;)   (cond     ( (null msxl-xl24HourClock)       (if (setq tlbfile (DSX-TypeLib-Excel)         (progn (setq tlbver (substr (vl-filename-base tlbfile) 6) (cond ( (= tlbver "9")  (princ "nInitializi

41、ng 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 &

42、#160;           :tlb-filename       tlbfile         :methods-prefix "msxl-"         :properties-prefix "msxl-"    &

43、#160;    :constants-prefix "msxl-"       )       (if msxl-xl24HourClock (setq out T)     )   )     )     ( T (setq out T) )   ) out ) ;* ; MODULE: DSX-Open-Excel-New ; DE

44、s 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 "nCreati

45、ng new Excel Spreadsheet file.") (cond ( (setq appsession (vlax-create-object "Excel.Application")       (vlax-invoke-method         (vlax-get-property appsession 'WorkBooks)         

46、9;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,

47、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 "nOpen

48、ing 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) &

49、#160;       'Open fn       )   (if (= (strcase dmode) "SHOW")    (vla-put-visible appsession 1) (vla-put-visible appsession 0) ) ) )   ) ( T (alert (strcat "nCannot locate source file: " xfile) )  

50、; ) 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

51、,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)     

52、  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 '("

53、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       (

54、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) ; EXAM

55、PLE: (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-RowCellsCol

56、or ; 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)  

57、; (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

58、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-P

59、ut-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 (relco

60、l) 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)   

61、60;   (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:

62、 (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-A

63、ctiveSheet 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-Exc

64、el-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           

65、60;       (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) ) ); repeat out ) ;* ; M

66、ODULE: 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 numce

67、lls / 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) ) ); repeat