坐標(biāo)提取lisp程序

1、精選優(yōu)質(zhì)文檔-傾情為你奉上坐標(biāo)提取lisp程序  2010-05-17 20:50:07|  分類： |  標(biāo)簽： |字號大中小 訂閱 ;該程序主要用于CAD點(diǎn)（point）三維坐標(biāo)提取，并將數(shù)據(jù)輸出為CASS軟件中使用的數(shù)據(jù)格式;輸出格式： 點(diǎn)號,測量Y值，測量X值，測量Z值   例：1,100.3244,1232,433,25;2010-05-17    ;命令：plzbsc(defun c:plzbsc()   (princ "n選擇所需輸

2、出的點(diǎn)（point）:")   (setq ss (ssget );選取坐標(biāo)點(diǎn)   (setq n (sslength ss );計(jì)算坐標(biāo)點(diǎn)數(shù)量        (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);將坐標(biāo)值實(shí)數(shù)轉(zhuǎn)換成字符       (setq sy (rtos (nth 0 lxyz)       (setq sz (rtos (nth 2 l

5、xyz)                                        (setq i1 (+ i 1);計(jì)算點(diǎn)序號      

6、60;                                 (setq sn (rtos i1 2 0);將序號實(shí)數(shù)轉(zhuǎn)換成字符       (setq sxyz (strcat sn","

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

8、)地形圖上提取碎步點(diǎn)（高程點(diǎn)）坐標(biāo)并輸出到文本  2010-05-18 08:50:38|  分類： |  標(biāo)簽： |字號大中小 訂閱 利用程序提取地形圖上碎步點(diǎn)的三維坐標(biāo)。并輸出到記事本中，該程序待修改的地方是不能選取點(diǎn)，并輸出數(shù)據(jù)，待改正。(defun c:gcdtq()(setvar "cmdecho" 0) ;指令執(zhí)行過程不響應(yīng)(setq en (entsel "選擇高程點(diǎn):") ;要求碰選一個(gè)高程點(diǎn)(setq ff (open (getfiled "文件保存為&qu

9、ot; "f:/" "txt" 1) "a")(setq en_data (entget (car en) ;取得元體資料列表(setq pt (cdr (assoc 10 en_data) ;求得高程點(diǎn)坐標(biāo)pt(setq py(rtos (nth 1 pt);提取測量坐標(biāo)Y值(setq px(rtos (nth 0 pt);提取測量坐標(biāo)X值(setq pz(rtos (nth 2 pt);提取測量坐標(biāo)Z值(setq sxyz (strcat px "      &

10、#160;    "  py  "           "  pz)(write-line sxyz ff)(prin1)(prompt "* << C:gcdtq >> *")(prin1)連續(xù)選取高程點(diǎn)并輸出到文本  2010-05-18 15:33:49|  分類： |  標(biāo)簽： |字號大中小

11、60;訂閱 ;2010-05-18  武赤公路;用于提取地形圖中的高程點(diǎn)（碎步點(diǎn)）坐標(biāo)，同時(shí)可以提取點(diǎn)（point）的坐標(biāo);本程序的缺點(diǎn)是不能過濾對象，同時(shí)也成為了他的優(yōu)點(diǎn)；沒有限制點(diǎn)的樣式，塊也可以，點(diǎn)也可以；;本程序設(shè)計(jì)保存文件是可以在已有文件中繼續(xù)添加數(shù)據(jù)，但是序號不再累積；這樣可以判斷不同時(shí)期選取的數(shù)據(jù)(defun c:gcdtq()(setvar "cmdecho" 0) ;指令執(zhí)行過程不響應(yīng)(setq ff (open (getfiled "文件保存為" "f:/" "dat" 1) &quo

12、t;a")(setq en (entsel "選擇高程點(diǎn):");要求碰選一個(gè)高程點(diǎn)(setq i 1);生成序號(while en(setq en_data (entget (car en) ;取得元體資料列表(setq pt (cdr (assoc 10 en_data) ;求得高程點(diǎn)坐標(biāo)pt(setq py(rtos (nth 1 pt);提取測量坐標(biāo)系Y值(setq px(rtos (nth 0 pt);提取測量坐標(biāo)洗X值(setq pz(rtos (nth 2 pt);提取測量坐標(biāo)系Z值(setq pi(rtos i 2 0)(setq pxyz (str

13、cat pi"," px ","  py  ","  pz);輸出為CASS數(shù)據(jù)格式(write-line pxyz ff);寫入文本(setq en (entsel "n選擇下一個(gè)高程點(diǎn)<回車結(jié)束選擇>:")(setq i (+ i 1)(close file)(prin1)(prompt "*從CASS中提取高程點(diǎn)或（point）點(diǎn)坐標(biāo)，* << C:gcdtq >> *高程點(diǎn)提取*")(prin1)橫斷面數(shù)據(jù)提?。ù薷模?

14、#160; 2010-05-18 21:59:09|  分類： |  標(biāo)簽： |字號大中小 訂閱 (defun c:hdm()(setvar "cmdecho" 0) ;指令執(zhí)行過程不響應(yīng);計(jì)算方位角(setq ff (open (getfiled "文件保存為" "c:/" "hdm" 1) "a")(setq zh (getreal"請輸入樁號：");計(jì)算橫斷面上點(diǎn)到中心線的垂距，數(shù)值分正負(fù)(setq pt1 (

15、getpoint "n拾取縱斷面上的一點(diǎn)：");用于確定橫斷面上的零點(diǎn)位置(setq x1 (car pt1);給縱斷面上一點(diǎn)X賦值x1(setq y1 (cadr pt1);給縱斷面上一點(diǎn)Y賦值y1(setq pt2 (getpoint "n拾取縱斷面上的第二點(diǎn)：");用于確定橫斷面上的零點(diǎn)位置(setq x2 (car pt2);給縱斷面上一點(diǎn)X賦值x1(setq y2 (cadr pt2);給縱斷面上一點(diǎn)Y賦值y1;計(jì)算縱斷面（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);方位角計(jì)算(setq ang (/(* fwj pi) 180)(setq en (entsel "選擇高程點(diǎn):");要求碰選一個(gè)高程點(diǎn)(while en(setq en_data (entget (car en) ;取得元體資料列表(setq pt (cdr (a

17、ssoc 10 en_data) ;求得高程點(diǎn)坐標(biāo)pt(setq py (nth 1 pt);提取測量坐標(biāo)系Y值(setq px (nth 0 pt);提取測量坐標(biāo)洗X值(setq px2 (sin ang)(setq px3 (cos ang)(setq cj (-(* (- py y1) (cos ang) (* (- px x1) (sin ang);計(jì)算垂直距離（cj）(setq dist (rtos cj 2 0)(setq pz(rtos (nth 2 pt);提取測量坐標(biāo)系Z值(setq pdz (strcat dist","pz);輸出為CASS數(shù)據(jù)格式(w

18、rite-line pdz ff);寫入文本(setq en (entsel "n選擇下一個(gè)高程點(diǎn)<回車結(jié)束選擇>:")(close file)(prin1)(prompt "*從CASS中提取高程點(diǎn)或（point）點(diǎn)坐標(biāo)，* << C:hdm >> *輸出橫斷面數(shù)據(jù)（平距，高程）*")(prin1)批量提取CAD中點(diǎn)（point）三維坐標(biāo)  2010-05-22 23:11:43|  分類： |  標(biāo)簽： |字號大中小 訂閱 ;該程序主要用于CAD

19、點(diǎn)（point）三維坐標(biāo)提取，并將數(shù)據(jù)輸出為CASS軟件中使用的數(shù)據(jù)格式;輸出格式： 點(diǎn)號,測量Y值，測量X值，測量Z值   例：1,100.3244,1232,433,25;2010-05-17    羅澤鋼   中國葛洲壩集團(tuán)基礎(chǔ)工程有限公司;命令：plzbsc(defun c:plzbsc()   (princ "n選擇所需輸出的點(diǎn)（point）:")   (setq ss (ssget );選取坐標(biāo)點(diǎn)   (setq n (sslengt

20、h ss );計(jì)算坐標(biāo)點(diǎn)數(shù)量        (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);將坐標(biāo)值實(shí)數(shù)轉(zhuǎn)換成字符       (setq sy (rtos (nth 0 lxyz)       (setq sz (rtos (nth 2 lxyz)             &

23、#160;                          (setq i1 (+ i 1);計(jì)算點(diǎn)序號                    &#

24、160;                   (setq sn (rtos i1 2 0);將序號實(shí)數(shù)轉(zhuǎn)換成字符       (setq sxyz (strcat sn","  sy ","  sx  ","  sz)   

25、60;   (write-line sxyz ff)    )    )    (setq i (+ i 1)   );repeat )(prompt "*只適合point點(diǎn) << 命令:plzbsc >> *輸出格式（點(diǎn)號, Y，X，Z）*")(prin1)從CASS提取高程點(diǎn)坐標(biāo)輸出到文本  2010-05-22 23:15:18|  分類： | &

26、#160;標(biāo)簽：       |字號大中小 訂閱 :2010-05-17 (defun c:gcdtq()(setvar "cmdecho" 0) ;指令執(zhí)行過程不響應(yīng)(setq en (entsel "選擇高程點(diǎn):") ;要求碰選一個(gè)高程點(diǎn)(setq ff (open (getfiled "文件保存為" "f:/" "txt" 1) "a")(setq en_data (entget (car en) ;

27、取得元體資料列表(setq pt (cdr (assoc 10 en_data) ;求得高程點(diǎn)坐標(biāo)pt(setq py(rtos (nth 1 pt);提取測量坐標(biāo)Y值(setq px(rtos (nth 0 pt);提取測量坐標(biāo)X值(setq pz(rtos (nth 2 pt);提取測量坐標(biāo)Z值(setq sxyz (strcat px "           "  py  "     

28、60;     "  pz)(write-line sxyz ff)(prin1)(prompt "* << C:gcdtq >> *")(prin1); 修改后可以實(shí)現(xiàn)連續(xù)提取2011-02-25(defun c:gcdtq()(setvar "cmdecho" 0) ;指令執(zhí)行過程不響應(yīng)(setq ff (open (getfiled "文件保存為" "f:/" "dat" 1) "a&q

29、uot;)(setq n 0)(while;循環(huán)語句(setq en (entsel "n 選擇高程點(diǎn):") ;要求碰選一個(gè)高程點(diǎn)(redraw (car en) 3);亮顯高程點(diǎn)(setq n(+ n 1)(setq pn(rtos n 2 0)(setq en_data (entget (car en) ;取得元體資料列表(setq pt (cdr (assoc 10 en_data) ;求得高程點(diǎn)坐標(biāo)pt(setq py(rtos (nth 1 pt);提取測量坐標(biāo)Y值(setq px(rtos (nth 0 pt);提取測量坐標(biāo)X值(setq pz(rtos (nt

30、h 2 pt);提取測量坐標(biāo)Z值(setq sxyz (strcat pn","px ","  py  ","  pz)(write-line sxyz ff)(prin1)(princ sxyz)(prompt "* << C:gcdtq >> *提取高程點(diǎn)輸出為CASS格式*")(prin1);VLISP與EXCEL之間連接及數(shù)據(jù)傳輸和函數(shù)集  2011-05-29 08:35:14|  分類： | 

31、0;標(biāo)簽： |字號大中小 訂閱  *; ; 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