从CASS中提取高程点坐标输出至文本（图面连续拾取，可框选）【原】

纳兰龙珠

fanqinwei 发表于 2012-12-22 09:59
这个CASS本身自带，不必再去编写

求教，怎么调用，谢谢

蓝图测绘

我也来一个，在"Gu_xl” 版主的基础上，加了一个用范围线选择高程点生成数据文件。

;有选择性的拾取高程点生成DAT文件
;有点选、框选、范围线3种选择方式
(defun c:g2d()
  (setvar "cmdecho" 0)
  (setq file (getfiled "文件保存为" "" "dat" 1))
  (if (findfile file)
    (setq ff (open file "a"))
    (setq ff (open file "w"))
  )
  (setq xzfs (getint "\n高程点选择方式:[图上拾取( 1 )] / [选择范围线( 2 )]: < 1 >"))
  (if (= xzfs nil) (setq xzfs 1))
  (if (= xzfs 2)
    (progn
      (while (null (setq fwx (car (entsel "\n选择范围线(闭合多边形):")))))
      (setq bh (cdr (assoc 70 (entget fwx))))
      (if (or (= bh 0) (= bh 128))
        (progn
          (alert "你选择的范围线没有闭合")
          (while (null (setq fwx (car (entsel "\n选择范围线(闭合多边形):")))))
          (setq bh (cdr (assoc 70 (entget fwx))))
          (if (or (= bh 0) (= bh 128)) (exit))
        )
      )
      (setq fwxb (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget fwx))))
    )
  )
  (cond
    ((= xzfs 1) (setq ss (ssget '((0 . "insert") (2 . "gc200")))))
    ((= xzfs 2) (setq ss (ssget "wp" fwxb '((0 . "INSERT") (2 . "GC200")))))
  )
  (setq i 0)
  (repeat (sslength ss)
    (setq en (ssname ss i))
    (setq en_data (entget en))
    (setq pt (cdr (assoc 10 en_data)))
    (setq i (1+ i))
    (setq str (strcat (rtos i 2 0) ",," (rtos (car pt) 2 3) ","  (rtos (cadr pt) 2 3)  ","  (rtos (caddr pt) 2 3)))
    (write-line str ff)
  )
  (close ff)
  (princ (strcat "\n文件保存位置==>: " file))
  (princ "\n本次总共提取了 ") (princ i) (princ " 个高程点")
  (prin1)
)
(princ "\n蓝图测绘，精心制作; 键入 g2d 运行本插件")

chaojibiantai

O(∩_∩)O谢谢分享

树櫴希德

蓝图老师好样的

ningwy001

谢谢学习学习

gzbccy

高人很多啊。其实主要是加强学习下才可以

qunaihan

蓝图大师的程序运行时出现这个：选择范围线(闭合多边形):; 错误: 参数类型错误: lselsetp nil。不知是哪里的问题？望指教。谢谢！！！

chbddzx12

..........................

skg123

当高程点 移动了，使用下面的程序读取 属性值（属性值=高程值）
(vl-load-com)
(defun c:TT()
(setq i 1)
(setq word (getstring "\n请输入断面编号:"))
(while  
     (if (setq ent (car (entsel "\n请选取高程点:")))
         (if (= (cdr (assoc 0 (entget ent))) "INSERT")
             (if (= (vlax-get (setq obj (vlax-ename->vla-object ent)) "HasAttributes") -1)
                 (progn
                    (setq att (vlax-invoke obj "GetAttributes"))
                    (setq jgb (mapcar '(lambda(aobj) (vlax-get aobj "TextString")
                                       )
                                       att
                              )
                    )
                    (princ word )(princ "号断面")(princ i )(princ "号点高程值：")(princ jgb) (princ "\n")
                 )
             )
         )  
      )

   (setq i (+ 1 i))
     (princ)
);end while
)

aumyshow

谢谢分享
~~~~~~~~~~~~