cass高程点过滤保留点位，求改进完美

P123ZX · 发表于 2015-7-15 21:49:23

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

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

×

(defun xd-Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(vla-get-selectionsets
(vla-get-activedocument (vlax-get-acad-object)) ;_
)
"CURRENT"
)
)
)
)
)
(vla-delete cset)
)
(princ)
)
(defun xd-cset ()
(setq *doc (vla-get-activedocument (vlax-get-acad-object))
*sets (vla-get-selectionsets *doc)
)
(if (ssget "P")
(vla-delete (vla-item *sets 0))
)
(vla-get-activeselectionset *doc)
)
(defun ai_deselect ()
(if (= (getvar "cmdecho") 0) ;_start if
(command "_.select" "_r" "_all" "")
(progn ;_start progn for cmdecho 1
(setvar "cmdecho" 0)
(command "_.select" "_r" "_all" "")
(setvar "cmdecho" 1)
) ;_end progn for cmdecho 1
) ;_end if
;;(terpri)
;;(prompt "所有对象都已取消选择")
(princ)
)
(defun xdelatt (*cad / FIL SS *cad)
(princ "\n 删除块属性----------by lxx.2007.9")
(princ "\n 选择要删除属性的块<全部>:")
;(setq *cad (vlax-ename->vla-object (CAR(ENTSEL))))
(setq *cad (vlax-get-acad-object))
(xd-Clearcset);;;;;;;;;;;;;;;;;;;;;
(setq fil '((0 . "INSERT") (-4 . "&") (66 . 1)))
;(or (setq ss (ssget fil))
;(setq ss (ssget "x" fil))
;)
(vla-eval *cad
"for each i in thisdrawing.activeselectionset : for each n in i.getattributes : n.delete :next n :next i"
)
)
;;;;;;;;;;;;;;;
(defun lst-(l1 l2)
(vl-remove-if'(lambda(x)(member x l2))l1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:pjz(/ p1 p2 ss sn si i x y e fw pzxa pzxb pzxzx *cad)
(prompt "**从CASS中提取高程点计算高程累计和和平均数，请在命令行输入 pjz **")
(setq sn 0)
(setq zh 0)
(setq ss(ssget (list(cons 8 "**")(cons 2 "GC200"))))
(if ss(progn
(setq fw(open "d:\\ex.dat" "w"))
(setq sn(sslength ss))
(setq i 0)
(while(< i sn)
(setq si(ssname ss i))
;=====提取坐标=================
(setq pt(cdr(assoc 10 (entget si))))
(setq x(rtos(car pt)2 3) y(rtos(cadr pt)2 3) e(rtos(caddr pt)2 3))
(setq pzxa(list (atof x) (atof y) (atof e)))
(setq pzxb (append pzxb (list pzxa)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun delsameok(l1 rcz / l2);;带容差去重(重复过的取第一次出现)，有时处理坐标点需要考虑容差
(while l1
(setq l2(cons(car l1)l2)l1(vl-remove-if'(lambda (x)(equal(car l1)x rcz))(cdr l1))))
(reverse l2))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun delsame(l1 rcz / l2);;带容差去重(重复过的不出现)，有时处理坐标点需要考虑容差
(while (setq l1(vl-remove-if'(lambda (x)(equal(car l1)x rcz))(cdr l1)))
(setq l2(cons(car l1)l2)))
(reverse l2))
;;;;;;;;;;;;;;;;;;;;;
(princ(strcat (itoa (1+ i))",**," x "," y "," e "\n") fw)
(setq i(1+ i))
;=====计算平均值==============
(setq pz (nth 2 pt));提取测量坐标洗z值
(setq pz1 (rtos (nth 2 pt)));提取测量坐标系Z值
(setq zh (+ zh pz))
(setq pj (/ zh i))
(setq si (rtos i 2 0))
(setq zh1 (rtos zh 2 3))
(setq pj1 (rtos pj 2 3))
(setq pdz (strcat "本次共拾取" si "点,高程累计值:" zh1 ",高程平均值: "pj1 ",坐标文件在D盘;")) ;输出为数据格式（高程，累计和，平均值）
)
(setq pzxzx (lst- pzxb (delsame pzxb 5)))
(foreach n pzxzx
(xdelatt (setq *cad (ssget n)))
)
(close fw)
))
(princ pdz)
)

(defun xd-Clearcset (/ cset) 
  (if (not (vl-catch-all-error-p 
             (setq cset 
                    (vl-catch-all-apply 
                      'vla-item 
                      (list 
                        (vla-get-selectionsets 
                          (vla-get-activedocument (vlax-get-acad-object)) ;_ 
                        ) 
                        "CURRENT" 
                      ) 
                    ) 
             ) 
           ) 
      ) 
    (vla-delete cset) 
  ) 
  (princ) 
) 
 
(defun xd-cset () 
  (setq        *doc  (vla-get-activedocument (vlax-get-acad-object)) 
        *sets (vla-get-selectionsets *doc) 
  ) 
  (if (ssget "P") 
    (vla-delete (vla-item *sets 0)) 
  ) 
  (vla-get-activeselectionset *doc) 
) 
 
(defun ai_deselect () 
  (if (= (getvar "cmdecho") 0) ;_start if 
    (command "_.select" "_r" "_all" "") 
    (progn ;_start progn for cmdecho 1 
      (setvar "cmdecho" 0) 
      (command "_.select" "_r" "_all" "") 
      (setvar "cmdecho" 1) 
    ) ;_end progn for cmdecho 1 
  ) ;_end if 
  ;;(terpri) 
  ;;(prompt "所有对象都已取消选择") 
  (princ) 
) 
 
(defun xdelatt (*cad / FIL SS *cad) 
  (princ "\n 删除块属性----------by lxx.2007.9") 
  (princ "\n 选择要删除属性的块<全部>:") 
  ;(setq *cad (vlax-ename->vla-object (CAR(ENTSEL)))) 
   
 
    (setq *cad (vlax-get-acad-object)) 
  (xd-Clearcset);;;;;;;;;;;;;;;;;;;;; 
   
  (setq fil '((0 . "INSERT") (-4 . "&") (66 . 1))) 
  ;(or (setq ss (ssget fil)) 
      ;(setq ss (ssget "x" fil)) 
  ;) 
  (vla-eval *cad 
     "for each i in thisdrawing.activeselectionset : for each n in i.getattributes : n.delete :next n :next i" 
  ) 
   
) 
;;;;;;;;;;;;;;; 
(defun lst-(l1 l2) 
(vl-remove-if'(lambda(x)(member x l2))l1)) 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun c:pjz(/ p1 p2 ss sn si i x y e fw pzxa pzxb pzxzx *cad) 
(prompt "**从CASS中提取高程点计算高程累计和 和平均数，请在命令行输入 pjz **") 
 (setq sn 0) 
 (setq zh 0) 
  (setq ss(ssget  (list(cons 8 "**")(cons 2 "GC200")))) 
 (if ss(progn 
  (setq fw(open "d:\\ex.dat" "w")) 
  (setq sn(sslength ss)) 
  (setq i 0) 
  (while(
   (setq si(ssname ss i)) 
;=====提取坐标================= 
   (setq pt(cdr(assoc 10 (entget si)))) 
   (setq x(rtos(car pt)2 3) y(rtos(cadr pt)2 3) e(rtos(caddr pt)2 3)) 
   (setq pzxa(list (atof x) (atof y) (atof e))) 
    (setq pzxb (append pzxb (list pzxa))) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun delsameok(l1 rcz / l2);;带容差去重(重复过的取第一次出现)，有时处理坐标点需要考虑容差 
  (while l1 
    (setq l2(cons(car l1)l2)l1(vl-remove-if'(lambda (x)(equal(car l1)x rcz))(cdr l1)))) 
  (reverse l2)) 
;;;;;;;;;;;;;;;;;;;;;;;;; 
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun delsame(l1 rcz / l2);;带容差去重(重复过的不出现)，有时处理坐标点需要考虑容差 
  (while (setq l1(vl-remove-if'(lambda (x)(equal(car l1)x rcz))(cdr l1))) 
    (setq l2(cons(car l1)l2))) 
  (reverse l2)) 
    ;;;;;;;;;;;;;;;;;;;;; 
    
 
    
   (princ(strcat (itoa (1+ i))",**," x "," y "," e "\n") fw) 
    
   (setq i(1+ i)) 
;=====计算平均值============== 
(setq pz (nth 2 pt));提取测量坐标洗z值 
(setq pz1 (rtos (nth 2 pt)));提取测量坐标系Z值 
(setq zh (+ zh pz)) 
(setq pj (/ zh i)) 
(setq si (rtos i 2 0)) 
(setq zh1 (rtos zh 2 3)) 
(setq pj1 (rtos pj 2 3)) 
(setq pdz (strcat "本次共拾取" si "点,高程累计值:" zh1 ",高程平均值: "pj1 ",坐标文件在D盘;")) ;输出为数据格式（高程，累计和，平均值） 
 
  ) 
(setq pzxzx (lst- pzxb (delsame pzxb 5))) 
    (foreach n pzxzx 
(xdelatt (setq *cad (ssget n))) 
 
      ) 
   
   
  (close fw) 
 
 )) 
 (princ pdz) 
)

iLisp · 发表于 2015-7-15 22:46:26

(defun c:tt (/ ss lst i)
(setvar "dimzin" 0)
(if (setq ss (ssget (list (cons 8 "**") (cons 2 "GC200"))))
(progn
(setq lst (mapcar '(lambda (x / p)
(setq p (xdrx_getpropertyvalue x "Position"))
(list p p)
)
(xdrx_pickset->ents ss)
)
lst (xd::list:groupbyindex lst 5)
lst (mapcar 'car (mapcar 'cdr lst))
i 0
lst (mapcar '(lambda (x)
(strcat (itoa (setq i (1+ i)))
","
(xdrx_string_join (mapcar '(lambda (a) (rtos a 2 3))
x
)
","
)
)
)
lst
)
)
(xd::list:tofile "d:\\ex.dat" lst)
)
)
(princ)
)

(defun c:tt (/ ss lst i) 
  (setvar "dimzin" 0) 
  (if (setq ss (ssget (list (cons 8 "**") (cons 2 "GC200")))) 
    (progn 
      (setq lst        (mapcar        '(lambda (x / p) 
                           (setq p (xdrx_getpropertyvalue x "Position")) 
                           (list p p) 
                         ) 
                        (xdrx_pickset->ents ss) 
                ) 
            lst        (xd::list:groupbyindex lst 5) 
            lst        (mapcar 'car (mapcar 'cdr lst)) 
            i        0 
            lst        (mapcar        '(lambda (x) 
                           (strcat (itoa (setq i (1+ i))) 
                                   "," 
                                   (xdrx_string_join (mapcar '(lambda (a) (rtos a 2 3)) 
                                                             x 
                                                     ) 
                                                     "," 
                                   ) 
                           ) 
                         ) 
                        lst 
                ) 
      ) 
      (xd::list:tofile "d:\\ex.dat" lst) 
    ) 
  ) 
  (princ) 
)

xhwcj@sina.com · 发表于 2015-7-16 08:30:31

学习一下，楼主好啊。。。。。。。。。。。。。。。。:):)

树櫴希德 · 发表于 2015-7-16 10:00:00

iLisp 发表于 2015-7-15 22:46

请问这些函数源码在哪里？在晓东搜了很久没有找到

树櫴希德 · 发表于 2015-7-16 10:06:21

iLisp 发表于 2015-7-15 22:46

XDRX函数公开源码吗

iLisp · 发表于 2015-7-16 10:20:44

树櫴希德发表于 2015-7-16 10:06
XDRX函数公开源码吗

xdrx 是 ObjectARX 定义的 LispFunction，没有源码，加载对应 arx 文件即可使用

树櫴希德 · 发表于 2015-7-16 10:38:24

iLisp 发表于 2015-7-16 10:20
xdrx 是 ObjectARX 定义的 LispFunction，没有源码，加载对应 arx 文件即可使用

(defun c:tt (/ ss lst i)
(setvar "dimzin" 0)
(if (setq ss (ssget (list (cons 1 "insert")(cons 8 "**") (cons 2 "GC200"))))
(progn
(setq lst (mapcar '(lambda (x / p)
(setq p (xdrx_getpropertyvalue x "Position"))
(list p p)
)
(xdrx_pickset->ents ss)
)
lst (xd::list:groupbyindex lst 5);;;;;;;;;
lst (mapcar 'car (mapcar 'cdr lst))
i 0
lst (mapcar '(lambda (x)
(strcat (itoa (setq i (1+ i)))
","
(xdrx_string_join (mapcar '(lambda (a) (rtos a 2 3))
x
)
","
)
)
)
lst
)
)
(xd::list:tofile "d:\\ex.dat" lst)
)
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun XD::List:GroupByIndex (lst fuzz / ll ilst l index tf)
(or
(and
(listp (caar lst))
(setq ll (list (list (caar lst) (car lst)))
lst (cdr lst)
)
(while lst
(if (setq l
(mapcar
'cdr
(vl-remove-if-not
'(lambda (x) (equal (car x) (caar ll) fuzz))
lst
)
)
)
(setq ll (cons (append (cons (caar ll) l) (cdar ll)) (cdr ll))
lst (vl-remove-if
'(lambda (x) (equal (car x) (caar ll) fuzz))
lst
)
)
)
(setq ll (cons (list (caar lst) (car lst)) ll)
lst (cdr lst)
)
)
)
(and (setq index (caar lst))
(or (and (= (type index) 'INT)
(setq tf t
lst (mapcar
'(lambda (x) (cons (float (car x)) (cdr x)))
lst
)
)
)
(= (type index) 'REAL)
(= (type index) 'STR)
)
(setq
lst (vl-sort lst '(lambda (l1 l2) (< (car l1) (car l2))))
)
(mapcar '(lambda (x y / l)
(if (equal (caar ll) x fuzz)
(setq ll (cons (cons x
(cons y (cdar ll))
)
(cdr ll)
)
)
(setq ll (cons (list x y) ll))
)
)
(mapcar 'car lst)
lst
)
(if tf
(setq ll (mapcar '(lambda (x) (cons (fix (car x)) (cdr x))) ll))
)
)
)
(mapcar '(lambda (x)
(cons (car x)
(mapcar '(lambda (a)
(if (= (length a) 1)
(car a)
a
)
)
(mapcar 'cdr (cdr x))
)
)
)
(vl-remove nil ll)
)
)
;;;;;;;;;;;;;;;;;;;;;
(XD::List:ToFile
(strcat (vl-filename-directory (findfile fl))
"\"
(vl-filename-base fl)
".dat"
)
nl
)

(defun c:tt (/ ss lst i) 
  (setvar "dimzin" 0) 
  (if (setq ss (ssget (list (cons 1 "insert")(cons 8 "**") (cons 2 "GC200")))) 
    (progn 
      (setq lst        (mapcar        '(lambda (x / p) 
                           (setq p (xdrx_getpropertyvalue x "Position")) 
                           (list p p) 
                         ) 
                        (xdrx_pickset->ents ss) 
                ) 
            lst        (xd::list:groupbyindex lst 5);;;;;;;;; 
            lst        (mapcar 'car (mapcar 'cdr lst)) 
            i        0 
            lst        (mapcar        '(lambda (x) 
                           (strcat (itoa (setq i (1+ i))) 
                                   "," 
                                   (xdrx_string_join (mapcar '(lambda (a) (rtos a 2 3)) 
                                                             x 
                                                     ) 
                                                     "," 
                                   ) 
                           ) 
                         ) 
                        lst 
                ) 
      ) 
      (xd::list:tofile "d:\\ex.dat" lst) 
    ) 
  ) 
  (princ) 
) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun XD::List:GroupByIndex (lst fuzz / ll ilst l index tf) 
  (or 
    (and 
      (listp (caar lst)) 
      (setq ll        (list (list (caar lst) (car lst))) 
            lst        (cdr lst) 
      ) 
      (while lst 
        (if (setq l 
                   (mapcar 
                     'cdr 
                     (vl-remove-if-not 
                       '(lambda (x) (equal (car x) (caar ll) fuzz)) 
                       lst 
                     ) 
                   ) 
            ) 
          (setq        ll  (cons (append (cons (caar ll) l) (cdar ll)) (cdr ll)) 
                lst (vl-remove-if 
                      '(lambda (x) (equal (car x) (caar ll) fuzz)) 
                      lst 
                    ) 
          ) 
        ) 
        (setq ll  (cons (list (caar lst) (car lst)) ll) 
              lst (cdr lst) 
        ) 
      ) 
    ) 
    (and (setq index (caar lst)) 
         (or (and (= (type index) 'INT) 
                  (setq        tf  t 
                        lst (mapcar 
                              '(lambda (x) (cons (float (car x)) (cdr x))) 
                              lst 
                            ) 
                  ) 
             ) 
             (= (type index) 'REAL) 
             (= (type index) 'STR) 
         ) 
         (setq 
           lst (vl-sort lst '(lambda (l1 l2) (< (car l1) (car l2)))) 
         ) 
         (mapcar '(lambda (x y / l) 
                    (if        (equal (caar ll) x fuzz) 
                      (setq ll (cons (cons x 
                                           (cons y (cdar ll)) 
                                     ) 
                                     (cdr ll) 
                               ) 
                      ) 
                      (setq ll (cons (list x y) ll)) 
                    ) 
                  ) 
                 (mapcar 'car lst) 
                 lst 
         ) 
         (if tf 
           (setq ll (mapcar '(lambda (x) (cons (fix (car x)) (cdr x))) ll)) 
         ) 
    ) 
  ) 
  (mapcar '(lambda (x) 
             (cons (car x) 
                   (mapcar '(lambda (a) 
                              (if (= (length a) 1) 
                                (car a) 
                                a 
                              ) 
                            ) 
                           (mapcar 'cdr (cdr x)) 
                   ) 
             ) 
           ) 
          (vl-remove nil ll) 
  ) 
) 
;;;;;;;;;;;;;;;;;;;;; 
(XD::List:ToFile 
        (strcat        (vl-filename-directory (findfile fl)) 
                "\" 
                (vl-filename-base fl) 
                ".dat" 
        ) 
        nl 
      )

; 错误: 参数类型错误: stringp nil
_$
; 错误: 参数类型错误: stringp nil
_$
; 错误: 参数类型错误: stringp nil

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

[求助] cass高程点过滤保留点位，求改进完美

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

点评

点评

点评

浏览过的版块

[求助] cass高程点过滤保留点位，求改进 完美

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

点评

点评

点评

浏览过的版块

[求助] cass高程点过滤保留点位，求改进完美