获取多段线顶点XY座标，并写入到表格

tianyuan · 发表于 2014-5-29 12:04:03

很好的程序，可惜来晚了，值得学习

819534890 · 发表于 2014-5-29 16:26:31

真不错，学习了

lite · 发表于 2014-6-15 15:46:29

谢谢楼主,认真学习下！

langjs · 发表于 2014-6-15 17:28:43

我也来一个

，一个比较简单的方法

;;;多段线顶点坐标导出到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 1  ent (entget (ssname ss i))  p (cdr (assoc 10 ent)))
(write-line (strcat "Line" (itoa (1+ i))) file)
(write-line "

oint\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)
)

wzg356 · 发表于 2014-6-19 16:01:13

;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 )
(setq i 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))
)
(setq i 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)

;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 ) 
   (setq  i 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)) 
   ) 
   (setq  i 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)

香田里浪人 · 发表于 2014-6-20 14:10:59

langjs 发表于 2014-6-15 17:28
我也来一个，一个比较简单的方法

阁下写的程序是不错，可是不足之处是：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 1  ent (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)
)

四季因你而在 · 发表于 2014-6-20 19:18:56

新手学习，过来围观！

wzg356 · 发表于 2014-6-21 19:34:48

wzg356 发表于 2014-6-19 16:01

看看你系统的excel路径，改这句(setq office:dir "C:\\Program Files\\Microsoft Office\\")

豆豆_jing · 发表于 2014-6-22 11:31:05

卷柏 · 发表于 2014-6-28 23:47:25

flyfox1047 发表于 2014-2-19 09:59
答案是肯定的

楼主的程序确实强大，膜拜，可惜我才学习程序不久，能否发我一个提取三维点的源码，研究学习学习
非常感谢 412388169@QQ.COM

账号		自动登录	找回密码
密码			注册

[源码] 获取多段线顶点XY座标，并写入到表格

点评

点评

点评