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 (getfiled 文件保存为 f
2、:/ 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);将
3、序号实数转换成字符 (setq sxyz (strcat sn, sy , sx , sz) (write-line sxyz ff) ) (setq i (+ i 1) );repeat)(prompt * *输出格式（点号, Y，X，Z）*)(prin1)地形图上提取碎步点（高程点）坐标并输出到文本2010-05-18 08:50:38|分类： 工程 |标签： |字号大中小订阅 利用程序提取地形图上碎步点的三维坐标。并输出到记事本中，该程序待修改的地方是不能选取点，并输出数据，待改正。(defun c:gcdtq()(setvar cmdecho 0) ;指令执行过程不响应(setq en
4、 (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
5、)(prin1)(prompt * *)(prin1)连续选取高程点并输出到文本2010-05-18 15:33:49|分类： 工程 |标签： |字号大中小订阅 ;2010-05-18 武赤公路;用于提取地形图中的高程点（碎步点）坐标，同时可以提取点（point）的坐标;本程序的缺点是不能过滤对象，同时也成为了他的优点；没有限制点的样式，块也可以，点也可以；;本程序设计保存文件是可以在已有文件中继续添加数据，但是序号不再累积；这样可以判断不同时期选取的数据(defun c:gcdtq()(setvar cmdecho 0) ;指令执行过程不响应(setq ff (open (getfiled
6、文件保存为 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
7、 pi, px , py , pz);输出为CASS数据格式(write-line pxyz ff);写入文本(setq en (entsel n选择下一个高程点:)(setq i (+ i 1)(close file)(prin1)(prompt *从CASS中提取高程点或（point）点坐标，* *高程点提取*)(prin1)横断面数据提取（待修改）2010-05-18 21:59:09|分类： 工程 |标签： |字号大中小订阅 (defun c:hdm()(setvar cmdecho 0) ;指令执行过程不响应;计算方位角(setq ff (open (getfiled 文件保存为 c
8、:/ 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
9、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)
10、 ;取得元体资料列表(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)
11、;输出为CASS数据格式(write-line pdz ff);写入文本(setq en (entsel n选择下一个高程点:)(close file)(prin1)(prompt *从CASS中提取高程点或（point）点坐标，* *输出横断面数据（平距，高程）*)(prin1)批量提取CAD中点（point）三维坐标2010-05-22 23:11:43|分类： 默认分类 |标签： |字号大中小订阅 ;该程序主要用于CAD点（point）三维坐标提取，并将数据输出为CASS软件中使用的数据格式;输出格式： 点号,测量Y值，测量X值，测量Z值 例：1,100.3244,1232,433,25
12、;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 (s
13、etq 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点 *输出格式（点号, Y，X，
14、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(se
15、tq 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 * *)(prin1);修改后可以实现连续提取2011-02-25(defun c:gcdtq()(setvar cmdecho 0) ;指令执行过程不响应(setq ff (open (getfiled 文件保存为 f:/ dat 1) a)(setq n 0)(while;循环
16、语句(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 p
17、n,px , py , pz)(write-line sxyz ff)(prin1)(princ sxyz)(prompt * *提取高程点输出为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 ; ;*; ; Ve
18、rsion 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
19、 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
20、; EXAMPLE: (DSX-TypeLib-Excel) ;* (defun DSX-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 ) ( (se
21、tq 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) tlb ) ) ) ;* ; MODULE: DSX-Load-TypeLib-
22、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) (pr
23、ogn (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
24、-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: (
25、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
26、 (= (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-O
27、pen-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-ge
28、t-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 colum
29、n (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-p
30、ut-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
31、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-Pu
32、t-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)
33、 (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 usin
34、g 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: Cha
35、nge 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
