输出多段线顶点坐标的小程序

caddog · 发表于 2006-9-27 20:16:13

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

刚刚，因为工作的需要，编写了一个多段线顶点坐标输出的小程序，请各位高手指正

;;;--------------------------------------------------------
;;;函数： c:plout
;;;--------------------------------------------------------
;;;来源：　作者: hj
;;;功能：本函数提取多段线的各端点坐标值输出至文本文件
;;;语法：
;;;参数：
;;;返回值：
;;;备注：注意输出坐标格式为　点号　Y坐标　X坐标
;;;--------------------------------------------------------
(defun c:plout ()
(SETQ name (ENTSEL "\n<请选择要多段线>:"))
(princ)
(SETQ ename (CAR name));;取图元名
(SETQ $acdName1 (CDR (ASSOC 0 (ENTGET ename))))
(IF (WCMATCH $acdName1 "LWPOLYLINE,AcDbPolyline");;判断是否多段线
(SETQ $temp-name ename)
(SETQ $temp-name nil)
) ;_ 结束if
(if $temp-name
(progn
(setq pllist (GETPLLIST $temp-name));;调用子程序取多段线顶点坐标
(initget 4)
(setq num (getint "请输入小数位数：[2]"))
(if (= num nil)
(setq num 2)
)
(setq filename
(getfiled "选择文件存储目录" "多段线坐标.TXT" "TXT" 5)
)
(if filename
(progn
(plout:OutFile pllist filename (itoa num))
(setq message (strcat "\n 输出至文件:" filename))
(princ)
(princ message)
)
)
)
)
)
;;;函数： DIM:OutFile
;;;--------------------------------------------------------
;;; 说明：将界址点坐标输出到文件
;;; 语法：DIM:OutFile #plist-OutFile $filename-OutFile #precision-OutFile)
;;; #plist-OutFile.............界址点坐标点对表
;;; #plist-OutFile.............输出文件文件名
;;; #precision-OutFile.........界址点坐标取位精度
;;; 返回值："T" F NIL
;;; 备注本函数供C：DIMEJZD调用
;;;--------------------------------------------------------
(DEFUN plout:OutFile (#plist-OutFile $filename-OutFile
#precision-OutFile /
%jzd-jd $jzd-dh #jzd-zb
$jzd-zbX $jzd-zbY %id1
%id2 %resv-OutFile %rep
$open2 $open %rep1
%wordrow
)
;;; (SETQ $txtname (STRCAT $dwgpath
;;; (SUBSTR $dwgname 1 (- (STRLEN $dwgname) 4))
;;; ".txt"
;;; ) ;_ 结束strcat
;;; ) ;_ 结束setq
;;打开文件
(SETQ %jzd-jd (ATOI #precision-OutFile))
(SETQ $open (OPEN $filename-OutFile "w"))
(IF (NOT $open)
(PROGN
(PRINC
"\n 由于未知原因建立文件失败!文件保存至 C:/顶点坐标文件.txt 中!"
) ;_ 结束princ
(SETQ $filename-OutFile "C:\顶点坐标文件.txt")
(SETQ $open (OPEN $filename-OutFile "w"))
(IF (NOT $open)
(PROGN
(PRINC "\n 无法在C盘根目录下创建文件!程序将退出!")
(setq %resv-OutFile nil)
(EXIT)
) ;_ 结束progn
) ;_ 结束if
) ;_ 结束progn
) ;_ 结束if
(setq %id1 0)
(repeat (LENGTH #plist-OutFile)
;;(SETQ $jzd-dh (NTH %id1 #jzd-dhlist))
(setq $jzd-dh (itoa (+ %id1 1)))
;;取x,y坐标注记值
(SETQ #jzd-zb (NTH %id1 #plist-OutFile))
(SETQ $jzd-zbX (RTOS (CAR #jzd-zb) 2 %jzd-jd))
(SETQ $jzd-zbY (RTOS (CADR #jzd-zb) 2 %jzd-jd))
(write-line
(strcat $jzd-dh " " $jzd-zbY " " $jzd-zbX)
$open
)
(setq %id1 (+ 1 %id1))
)
(close $open)
(setq %resv-OutFile "T")
)
;;;--------------------------------------------------------
;;;函数： getPlList
;;;--------------------------------------------------------
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回
;;;
;;;
;;;编制者:高老师
;;;--------------------------------------------------------
(DEFUN getPlList (#entity / OBJ LW_T8 OBJ_1)
(SETQ obj (ENTGET #entity))
(SETQ lw_t8 (CDR (ASSOC 8 obj)))
(SETQ obj_1 nil)
(WHILE (/= (ASSOC 10 obj) nil)
(IF (AND (= (CAAR obj) 10)
(NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001))
) ;_ 结束and
(SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj))))
) ;生成坐标表同时去掉相邻重点,不带10
(SETQ obj (CDR obj))
) ;_ 结束while
(SETQ obj obj_1)
(IF (EQUAL (CAR obj) (LAST obj) 0.001)
(SETQ obj (REVERSE (CDR (REVERSE obj))))
) ;_ 结束if
;;判断首闭
(SETQ #temp obj)
) ;_ 结束defun
;;end defun

;;;-------------------------------------------------------- 
;;;函数： c:plout                                
;;;-------------------------------------------------------- 
;;;来源：           　作者: hj                
;;;功能：  本函数提取多段线的各端点坐标值输出至文本文件 
;;;语法：                  
;;;参数：   
;;;返回值： 
;;;备注：注意输出坐标格式为　点号　Y坐标　X坐标 
;;;-------------------------------------------------------- 
(defun c:plout () 
  (SETQ name (ENTSEL "\n<请选择要多段线>:")) 
  (princ) 
          (SETQ ename (CAR name));;取图元名 
          (SETQ $acdName1 (CDR (ASSOC 0 (ENTGET ename)))) 
          (IF (WCMATCH $acdName1 "LWPOLYLINE,AcDbPolyline");;判断是否多段线 
            (SETQ $temp-name ename) 
            (SETQ $temp-name nil) 
          ) ;_ 结束if 
          (if $temp-name 
            (progn 
              (setq pllist (GETPLLIST $temp-name));;调用子程序取多段线顶点坐标 
              (initget 4) 
              (setq num (getint "请输入小数位数：[2]")) 
              (if (= num nil) 
                (setq num 2) 
                ) 
              (setq filename 
                     (getfiled "选择文件存储目录" "多段线坐标.TXT" "TXT" 5) 
              ) 
              (if filename 
                (progn 
                (plout:OutFile pllist filename (itoa num)) 
                (setq message (strcat "\n 输出至文件:" filename)) 
                (princ) 
                (princ message) 
                ) 
              ) 
            ) 
          )    
) 
 
;;;函数： DIM:OutFile                                
;;;-------------------------------------------------------- 
;;; 说明：将界址点坐标输出到文件 
;;; 语法：DIM:OutFile #plist-OutFile $filename-OutFile #precision-OutFile) 
;;;       #plist-OutFile.............界址点坐标点对表 
;;;       #plist-OutFile.............输出文件文件名 
;;;       #precision-OutFile.........界址点坐标取位精度 
;;; 返回值："T"  F NIL 
;;; 备注  本函数供C：DIMEJZD调用 
;;;-------------------------------------------------------- 
 
(DEFUN plout:OutFile (#plist-OutFile                $filename-OutFile 
                    #precision-OutFile                / 
                    %jzd-jd          $jzd-dh        #jzd-zb 
                    $jzd-zbX          $jzd-zbY        %id1 
                    %id2          %resv-OutFile        %rep 
                    $open2          $open                %rep1 
                    %wordrow 
                   ) 
;;;              (SETQ $txtname (STRCAT $dwgpath 
;;;                           (SUBSTR $dwgname 1 (- (STRLEN $dwgname) 4)) 
;;;                           ".txt" 
;;;                           ) ;_ 结束strcat 
;;;            ) ;_ 结束setq 
 
  ;;打开文件 
  (SETQ %jzd-jd (ATOI #precision-OutFile)) 
  (SETQ $open (OPEN $filename-OutFile "w")) 
  (IF (NOT $open) 
    (PROGN 
      (PRINC 
        "\n 由于未知原因建立文件失败!文件保存至 C:/顶点坐标文件.txt 中!" 
      ) ;_ 结束princ 
      (SETQ $filename-OutFile "C:\顶点坐标文件.txt") 
      (SETQ $open (OPEN $filename-OutFile "w")) 
      (IF (NOT $open) 
        (PROGN 
          (PRINC "\n 无法在C盘根目录下创建文件!程序将退出!") 
          (setq %resv-OutFile nil) 
          (EXIT) 
        ) ;_ 结束progn 
        
      ) ;_ 结束if 
    ) ;_ 结束progn 
    
  ) ;_ 结束if 
  (setq %id1 0) 
  (repeat (LENGTH #plist-OutFile) 
    ;;(SETQ $jzd-dh (NTH %id1 #jzd-dhlist)) 
    (setq $jzd-dh (itoa (+ %id1 1))) 
    ;;取x,y坐标注记值 
    (SETQ #jzd-zb (NTH %id1 #plist-OutFile)) 
    (SETQ $jzd-zbX (RTOS (CAR #jzd-zb) 2 %jzd-jd)) 
    (SETQ $jzd-zbY (RTOS (CADR #jzd-zb) 2 %jzd-jd)) 
    (write-line 
      (strcat $jzd-dh "       " $jzd-zbY "       " $jzd-zbX) 
      $open 
    ) 
    (setq %id1 (+ 1 %id1)) 
  ) 
  (close $open) 
 
  (setq %resv-OutFile "T") 
) 
;;;-------------------------------------------------------- 
;;;函数： getPlList                                
;;;-------------------------------------------------------- 
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回 
;;;                
;;;                
;;;编制者:高老师                
;;;-------------------------------------------------------- 
 
(DEFUN getPlList (#entity / OBJ LW_T8 OBJ_1) 
  (SETQ obj (ENTGET #entity)) 
  (SETQ lw_t8 (CDR (ASSOC 8 obj))) 
  (SETQ obj_1 nil) 
  (WHILE (/= (ASSOC 10 obj) nil) 
    (IF        (AND (= (CAAR obj) 10) 
             (NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001)) 
        ) ;_ 结束and 
      (SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj)))) 
    )                                        ;生成坐标表同时去掉相邻重点,不带10 
    (SETQ obj (CDR obj)) 
  ) ;_ 结束while 
  (SETQ obj obj_1) 
  (IF (EQUAL (CAR obj) (LAST obj) 0.001) 
    (SETQ obj (REVERSE (CDR (REVERSE obj)))) 
  ) ;_ 结束if 
  ;;判断首闭 
  (SETQ #temp obj) 
) ;_ 结束defun 
;;end defun

zml84 · 发表于 2006-9-28 13:59:25

这些功能比较实用；如果能把三个功能集成为一个函数，那就更好了；但还是要谢谢楼主！

eachy · 发表于 2006-9-28 15:51:55

难得有人比较详细的贴自己的源码，在你的基础上改了改

(defun c:plout (/ s filename e n fn jd pt pts)
(if (setq s (ssget ":S" '((0 . "*POLYLINE")))) ;_点选带过滤形式
(progn
(setq e (ssname s 0)
n (fix (vlax-curve-getendparam e))
)
(if (not (setq filename
(getfiled "选择文件存储目录" "多段线坐标.txt" "txt" 5)
)
)
(setq filename "c:\\多段线坐标.txt")
)
(setq fn (open filename "w")
jd n
)
(setvar "dimzin" 0)
(repeat n
(setq pt (vlax-curve-getpointatparam e (setq jd (1- jd))))
(if (null pts)
(setq pts (list pt))
(if (not (equal pt (car pts) 1e-3))
(setq pts (cons pt pts))
)
) ;_去除重复
)
(setq n 1)
(mapcar '(lambda (x)
(write-line
(strcat (itoa n)
"\t"
(rtos (cadr x))
"\t"
(rtos (car x)) ;_与前面的 dimzin 配合采用用户 UNITS 精度设置
)
fn
)
(setq n (1+ n))
)
pts
)
(close fn)
)
)
(princ)
)

(defun c:plout (/ s filename e n fn jd pt pts) 
  (if (setq s (ssget ":S" '((0 . "*POLYLINE")))) ;_点选带过滤形式 
    (progn 
      (setq e (ssname s 0) 
            n (fix (vlax-curve-getendparam e)) 
      ) 
      (if (not (setq filename 
                      (getfiled "选择文件存储目录" "多段线坐标.txt" "txt" 5) 
               ) 
          ) 
        (setq filename "c:\\多段线坐标.txt") 
      ) 
      (setq fn (open filename "w") 
            jd n 
      ) 
      (setvar "dimzin" 0) 
      (repeat n 
        (setq pt (vlax-curve-getpointatparam e (setq jd (1- jd)))) 
        (if (null pts) 
          (setq pts (list pt)) 
          (if (not (equal pt (car pts) 1e-3)) 
            (setq pts (cons pt pts)) 
          ) 
        ) ;_去除重复 
      ) 
      (setq n 1) 
      (mapcar '(lambda (x) 
                 (write-line 
                   (strcat (itoa n) 
                           "\t" 
                           (rtos (cadr x)) 
                           "\t" 
                           (rtos (car x)) ;_与前面的 dimzin 配合采用用户 UNITS 精度设置 
                   ) 
                   fn 
                 ) 
                 (setq n (1+ n)) 
               ) 
              pts 
      ) 
      (close fn) 
    ) 
  ) 
  (princ) 
)

killer9806 · 发表于 2006-9-28 16:01:49

看了楼主和斑竹的代码，看来要好好学习objectarx代码！！！！！！！

雨箭风刀 · 发表于 2006-9-28 20:10:11

呵呵,楼上你......让大家都晕菜了 :D

bluice · 发表于 2006-9-30 14:35:46

试了下，还是可以用，但是假如自己定义个坐标系，好像不能量出自定义坐标系下的坐标。请看下是不是这样的啊，有没有办法解决?

SGP007 · 发表于 2008-12-25 09:30:52

再加上输出z值然后到excel 很好用谢谢

真奇怪，测试的时候还好好的。但是关闭了一次cad，再打开用plout就出现no function definition: VLAX-CURVE-GETENDPARAM的提示。
怎么回事呢？

zml84 · 发表于 2008-12-25 16:00:57

最初由 SGP007 发布
[B]再加上输出z值然后到excel 很好用谢谢

真奇怪，测试的时候还好好的。但是关闭了一次cad，再打开用plout就出现no function definition: VLAX-CURVE-GETENDPARAM的提示。
怎么回事呢？ [/B]

1.“输出到excel”，直接存*.et即可
2.(vl-load-com)

SGP007 · 发表于 2008-12-26 13:06:04

刚学不久，越来越发现，不懂这门外语真是不行了，还好有晓东空间，这么多高手支持，非常感谢

ningke969 · 发表于 2008-12-28 02:09:37

很实用

SGP007 · 发表于 2008-12-28 11:11:14

在lisp当中，如果设定变量在循环中反复拾取点，那么这两个点的距离怎么计算呢

kmdz · 发表于 2008-12-28 13:25:27

谢谢，源码很详细，可作为参考。

chunli_024 · 发表于 2009-5-7 16:14:38

请问一下啊这个表出来了但是具体在多段线上没有标示哪个点是1哪个点是2啊如何自动生成

阳阳 · 发表于 2024-7-22 13:21:56

谢谢源码分享！！

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

输出多段线顶点坐标的小程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子