很好的程序，可惜来晚了，值得学习
真不错，学习了
谢谢楼主,认真学习下！
我也来一个，一个比较简单的方法
;;;多段线顶点坐标导出到EXCEL
;;; by:langjs
(defun c:aa ( / ent file filex i j p ss)
(setq ss (ssget '((0 . "LWPOLYLINE")))i 0
filex (getfiled "指定输出文件路径" "" "xls" 1) file (open filex "w"))
(repeat (sslength ss)
(setq j 1ent (entget (ssname ss i))p (cdr (assoc 10 ent)))
(write-line (strcat "Line" (itoa (1+ i))) file)
(write-line "Point\tX\tY\tZ" file)
(entmake (list '(0 . "TEXT") (cons 1 (strcat "Line" (itoa (1+ i)))) (cons 10 (list (car p) (+ (cadr p) 50))) (cons 40 30)))
(while (setq p (assoc 10 ent))
(setq ent (cdr (member p ent)) p (cdr p))
(entmake (list '(0 . "TEXT") (cons 1 (itoa j)) (cons 10 (list (+ (car p) 10) (+ (cadr p) 10))) (cons 40 30)))
(write-line (strcat (itoa j) "\t" (rtos (car p) 2 4) "\t" (rtos (cadr p) 2 4) "\t"
(if (caddr p) (rtos (caddr p) 2 4)"0.0")) file )
(setq j (1+ j))
)
(setq i (1+ i))
)
(close file)
(command "start" filex)
(princ)
)
;46.2 [功能] pline,lwpline点坐标表By 无痕
;;示例(vxs (car (entsel))),返回三维点坐标
(defun vxs (e / i v lst)
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
;;;*下面这段代码来源于吴永进 林美樱的AutoCAD完全应用指南，
;;;*可以直接将多段线的顶点坐标输出到EXCEL中（2003 2007 2010都可以）
;;;根据输出三维点坐标表改了一点点
;;;******************************************************
;;; 将多段线相关点坐标写入EXCEL文件内
(defun c:xyz2excel ()
(setq pline_data_list (vxs (car (entsel "\n请选择多段线:"))));三维点表
(if (null MX-ACOS)
(jinn-get-excel-Lib)
)
(jinn-creat-excel-sheet)
(sub-xl-test4 pline_data_list)
(prin1)
)
;;将所有点坐标列表写入EXCEL各单元格中
(defun sub-xl-test4 (data_list / i j index )
(setqi 1 j 1 )
(foreach val '("序号" "X" "Y" "Z")
(setq ceobj (get-XL-cell sheetobj i j))
(put-cell-bkcolor ceobj 3 5 2 12 val)
(setq j (1+ j))
)
(setqi 2 j 1 index 1)
(foreach lista data_list
(setq ceobj (get-XL-cell sheetobj i j))
(mx-put-HorizontalAlignment ceobj 3)
;;向中对齐
(mx-put-value2 ceobj index)
(setq j (1+ j))
(foreach data lista
(setq ceobj (get-XL-cell sheetobj i j))
(mx-put-HorizontalAlignment ceobj 4)
;;向右对齐
(mx-put-value2 ceobj data)
(setq j (1+ j))
)
(setq i (1+ i) j 1 index (1+ index))
)
)
;;;创建EXCEL应用程序对象与窗体对象
(defun jinn-creat-excel-sheet ( / XLobj wb-obj cells)
(setq XLobj (vlax-create-object "Excel.Application"))
(vla-put-visible XLobj 1)
;; (vla-put-visible XLobj :vlax-true)
(setq wb-obj (vlax-invoke-method
(vlax-get-property XLobj 'WorkBooks)
'Add
)
)
(setq sheetobj (MX-get-activesheet wb-obj))
(setq cells (MX-get-cells sheetobj))
)
;;;加载EXCEL应用程序资源库文件
(defun jinn-get-excel-Lib ( / sys:drv office:dir xl-test4)
(setq sys:drv (getenv "systemdrive"))
(setq office:dir "C:\\Program Files\\Microsoft Office\\")
(cond
((setq exlib (findfile (strcat office:dir "office\\" "Excel8.olb")))
)
((setq exlib (findfile (strcat office:dir "office\\" "Excel9.olb")))
)
((setq exlib (findfile (strcat office:dir "office\\" "Excel.exe")))
)
((setq
exlib (findfile (strcat office:dir "office11\\" "Excel.exe"))
)
)
((setq
exlib (findfile (strcat office:dir "office12\\" "Excel.exe"))
)
)
(t (setq exlib nil))
)
(if exlib
(vlax-import-type-library
:tlb-filename exlib :methods-prefix
"MX-" :properties-prefix
"MX-" :constants-prefix "MX-"
)
(alert "Excel typelib 文件不存在")
)
)
;;;取得指定的单元格对象
(defun GET-XL-CELL (wkst row col)
(vlax-Variant-Value
(MX-Get-Item (MX-Get-Cells wkst) row col)
)
)
;; (put-cell-bkcolor 单元格对象 对齐方式 背景颜色 文字颜色 字号 数据内容)
(defun put-cell-bkcolor(obj atype bkcc txtcc txthh data)
(mx-put-horizontalalignment obj atype)
(mx-put-bold (mx-get-font obj) 1)
(mx-put-colorindex (mx-get-interior obj) bkcc)
(mx-put-colorindex (mx-get-font obj) txtcc)
(mx-put-size (mx-get-font obj) txthh)
(mx-put-value2 obj data)
)
;;(put-cell-txtcolor 单元格对象 对齐方式 文字颜色 字号 数据内容)
(defun put-cell-txtcolor (obj atype txtcc txthh data)
(mx-put-horizontalalignment obj atype)
(mx-put-bold (mx-get-font obj) 1)
(mx-put-colorindex (mx-get-font obj) txtcc)
(mx-put-size (mx-get-font obj) txthh)
(mx-put-value2 obj data)
)
(PRINC)
langjs 发表于 2014-6-15 17:28 static/image/common/back.gif
我也来一个，一个比较简单的方法
阁下写的程序是不错，可是不足之处是：1。编号点字高不能选择 2。EXCEL显示是数学坐标而不是地理坐标。3点号距离位置偏远。冒昧修改一下。程序如下：
;;;多段线顶点坐标导出到EXCEL
;;; by:langjs
(defun c:zbdc ( / ent file filex i j p ss)
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
(setq TextHeight (getdist "\n请输入文字高度:"))
(setq ss (ssget '((0 . "LWPOLYLINE")))i 0
filex (getfiled "指定输出文件路径" "" "xls" 1) file (open filex "w"))
(repeat (sslength ss)
(setq j 1ent (entget (ssname ss i))p (cdr (assoc 10 ent)))
(write-line (strcat "线段" (itoa (1+ i))) file)
(write-line "点号\tX\tY\tZ" file)
(entmake (list '(0 . "TEXT") (cons 1 (strcat "线段" (itoa (1+ i)))) (cons 10 (list (car p) (- (cadr p) 10)))(cons 7 "tukou") (cons 40 TextHeight)))
(while (setq p (assoc 10 ent))
(setq ent (cdr (member p ent)) p (cdr p))
(entmake (list '(0 . "TEXT") (cons 1 (itoa j)) (cons 10 (list (+ (car p) 0.01) (- (cadr p) 0.01)))(cons 7 "tukou") (cons 40 TextHeight)(cons 8 "编号")(cons 62 3) ))
(write-line (strcat (itoa j) "\t" (rtos (cadr p) 2 3) "\t" (rtos (car p) 2 3) "\t"
(if (caddr p) (rtos (caddr p) 2 3)"0.0")) file )
(setq j (1+ j))
)
(setq i (1+ i))
)
(close file)
(princ)
)
新手学习，过来围观！
wzg356 发表于 2014-6-19 16:01 static/image/common/back.gif
看看你系统的excel路径，改这句(setq office:dir "C:\\Program Files\\Microsoft Office\\")
flyfox1047 发表于 2014-2-19 09:59 static/image/common/back.gif
答案是肯定的
楼主的程序确实强大，膜拜，可惜我才学习程序不久，能否发我一个提取三维点的源码，研究学习学习
非常感谢 412388169@QQ.COM