坐标提取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选择所需输出的点(point):")(setq ss (ssget ); 选取坐标点(setq n (sslength ss );计算坐标点数量(setq ff (open (getfile

2、d "文件保存为""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 (

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

4、 工程|标签：|字号大中小 订阅利用程序提取地形图上碎步点的三维坐标。并输岀到记事本中，该程序待修改的地方是不能选取点，并输岀数据，待改正。(defun c:gcdtq()(setvar "cmdecho" 0); 指令执行过程不响应(setq en (entsel "选择高程点:");要求碰选一个高程点(setq ff (open (getfiled "文件保存为""f:/" "txt" 1) "a")(setq en_data (entget (car en);取得元体资

5、料列表(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 p x ""py ""pz)(write-line sxyz ff)(prin1)(prompt "* << C:gcdtq>>*“(prin1)连续选取高程点并输出到文本2010-05-18 15:

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

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

8、q pxyz (strcat pi"," px "," py "," pz);输出为 CASS 数据格式(write-line pxyz ff);写入文本(setq en (entsel "n选择下一个高程点 < 回车结束选择>:")(setq i (+ i 1)(close file)(prinl)(prompt "*从CASS中提取高程点或(point )点坐标，* << C:gcdtq >> *高程点提取*")(prinl)横断面数据提取(待修改)201

9、0-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拾取纵断面上的一点：");用于确定横断面上的

10、零点位置(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 (>

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

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

13、en (entsel "n 选择下一个高程点 < 回车结束选择>:")(close file)(prin1)(prompt "*从CASS中提取高程点或(point )点坐标，* << C:hdm >> *输出横断面数据(平距，高程)*")(prinl)批量提取CAD中点(point )三维坐标2010-05-22 23:11:43| 分类：默认分类|标签：|字号大中小 订阅;该程序主要用于CAD点(point)三维坐标提取，并将数据输出为CASS软件中使用的数据格式;输出格式：点号,，测量Y值，测量 X值，测量Z值

14、例：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 (s

15、sname 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 &qu

16、ot;," sx "," sz)(write-line sxyz ff)(setq i (+ i 1);repeat)(prompt "* 只适合 point 点 << 命令:plzbsc >> * 输出格式(点号，,Y, X, Z) *")(prinl)从CASS提取高程点坐标输出到文本2010-05-22 23:15:18| 分类： 工程|标签：高程点 提取cass|字号大中小 订阅:2010-05-17 (defun c:gcdtq()(setvar "cmdecho" 0); 指令执行过程不响

17、应(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 (

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

19、 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提取测量坐标Y值提取测量坐标X值提取测量坐标Z值," py ","pz)(setq py(rtos (nth 1

20、pt);(setq px(rtos (nth 0 pt);(setq pz(rtos (nth 2 pt);(setq sxyz (strcat pn","px(write-line sxyz ff) (prinl) (princ sxyz)(prompt "* << C:gcdtq >> *提取高程点输出为 CASS格式*")(prin1);VLISP与EXCEL之间连接及数据传输和函数集2011-05-29 08:35:14| 分类：工程|标签：|字号大中小订阅*J J JJ J J;DSX-API-Excel.LSP;Vis

21、ual LISP ActiveX API for Excel 97, 2000 and XP;Copyright (C)2002 David M. Ste in, All rights reserved;*J J JJ J J;Versio n 2002.22 05/15/02: In itial release;*J J JJ J J;Code provided AS-IS without warra nty of any kind give n for any purpose ; ;or use, either explicitly, implicitly or as a derivati

22、ve work item.;User assumes ANY AND ALL RISK and LIABILITY for use of any of this code ;for any con seque ntial damages of any kind. These functions are defi ned ;within DSX Tools 2002.22 when loaded into AutoCAD. This document is ;provided for in formatio nal purposes only.;*J J JJ J J(vl-load-com)

23、*J J J;MODULE: DSX-TypeLib-Excel;DEs criptION: Returns typelib (olb) file for either Excel 97, 2000, or XP;ARGS: none; EXAMPLE: (DSX-TypeLib-Excel) *( (setq tlb (findfileOfficeOfficeExcel8.olb")(strcatsysdrv"ProgramFilesMicrosofttlb)( (setq tlb (findfileOfficeOfficeExcel9.olb") tlb)(s

24、trcatsysdrv"ProgramFilesMicrosoft( (setq tlb (findfileOfficeOfficeExcel10.olb")(strcatsysdrv"ProgramFilesMicrosofttlb)( (setq tlb (findfile OfficeOfficeExcel.exe") tlb)(strcatsysdrv"ProgramFilesMicrosoft( (setq tlb (findfile(strcatsysdrv"ProgramFilesMicrosoft(defun DSX-

25、TypeLib-Excel ( / sysdrv tlb) (setq sysdrv (getenv "systemdrive") (condOfficeOffice10Excel.exe")tlb) *J J J; 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) *J J J(defun DSX-Load-

26、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.")

27、)( (= 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 "msx

28、l-" :constants-prefix "msxl-")(if msxl-xl24HourClock (setq out T)( T (setq out T) ) out ) *J J J; 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

29、"SHOW") *J J J(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 '

30、;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"

31、or "HIDE"); EXAMPLE: (setq xlapp (DSX-Open-Excel-Exist "myfile.xls" "SHOW") *J J J(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)(co

32、nd( (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 sour

33、ce file: " xfile) )appsession) *J J J; 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

34、into cells (1,B) (2,B) (3,B) respectively *J J J(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) *J J J; MODULE: DSX-Excel-Put

35、-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 *J J J(defun DSX-Excel-Put-RowL

36、ist (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) *J J J; MODULE: DSX-Excel-Put-CellColor; DEs criptION: Applies fill-color to specified cell; ARGS: row, colu

37、mn, color (integer); EXAMPLE: (DSX-Excel-Put-CellColor 1 1 14) apply color #14 to cell (1,A) *J J J(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) *J J J; MODULE: DSX-Excel-P

38、ut-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 / nex

39、t)(dsx-princ "n(DSX-Excel-Put-RowCellsColor)")(setq next startcol)(repeat cols(DSX-Excel-Put-CellColor startrow next intcol)(setq next (1+ next) *J J J; MODULE: DSX-Excel-Put-ColumnCellsColor; DEs criptION: Change fill color in a column of cells; ARGS: startrow, startcol, num-rows, color (

40、integer); EXAMPLE: (DSX-Excel-Put-ColumnCellsColor 1 1 5 14) Start at row=1 col=1 repeat for 5 rows using color #14 *J J J(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

41、-CellColor next startcol intcol)(setq next (1+ next) *J J J; MODULE: DSX-Excel-Get-Cell; DEs criptION: Get cell object relative to rangeusing (relrow) and (relcol)offsets; ARGS: range-object, relative-row, relative-col; EXAMPLE: (DSX-Excel-Get-Cell rng1 2 2) *J J J(defun DSX-Excel-Get-Cell (rng relr

42、ow 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(

43、int), column(int); EXAMPLE: (DSX-Excel-Get-CellValue 1 2) *J J J(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) *J J J; MODULE: DSX-Excel-Get-RowValues; DEs criptION: R

44、eturns 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)

45、(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) *J J J; MODULE: DSX-Excel-Get-ColumnValues; DEs criptION: Returns a list of cell values within a given column; ARGS: column-

46、number(int), startrow, num-cells; EXAMPLE: (DSX-Excel-Get-ColumnValues 2 1 20) get top-20 entries in column 2 ("B") *J J J(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

47、 out(append out (list (DSX-Excel-Get-CellValue next col)(list (DSX-Excel-Get-CellValue next col)next (1+ next); repeatout) *J J J; 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: (

48、DSX-Excel-GetRangeValues-ByRows 1 1 5 10) get range values from 1A to 5J where each sublist is one row *J J J(defun DSX-Excel-GetRangeValues-ByRows(startrow startcol numrows numcols / nextrow rowlst outlst)(dsx-princ "n(DSX-Excel-GetRangeValues-ByRows)")(setq nextrow startrow)(repeat numro

49、ws(setq rowlst (DSX-Excel-Get-RowValues nextrow startcol numcols)outlst (if outlst (append outlst (list rowlst) (list rowlst) nextrow (1+ nextrow)outlst) *J J J; 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