希望大神帮忙修改下面这个lisp,谢谢！

eddy_dqiao

下面这个lisp是搜集过来的一个有用程序，主要用于核对图纸工程量，一般市政排水管网中，会对管线平面上进行标注，标注格式为DN300(管径)-3(坡度)-30(管长)或者DN300(管径)-30(管长)-3(坡度），下面这个lisp程序可以一次多选图面中所有的平面管线标注，然后输入任意管径，可以给你统计出管长部分的总和，遗憾的是，这个程序只对“DN300(管径)-3(坡度)-30(管长)”的方式有效，当坡度和管长的位置互换时则无法统计总和；请大神帮忙修改下，使得程序能变成对“DN300(管径)-30(管长)-3(坡度)"的标注形式有效，能统计所有同管径的管长总和。谢谢！


源程序如下：
;本段程序帮你统计排水管道管长工程量。但前提是格式为“(DN***-**-***)
(Defun c:tps (/ sum sm sumst sc1 sc fil n e ed et j tzh tzh2 len ln)
(command "redraw")

(setq sum 0)
(setq sm 0)
(setq sumst 0)
(setq fil (ssget))
(setq sc1 (getstring "\n请输入需要统计的管径(以DN***表示):\n"))
(setq sc (strcase sc1))
(setq len (sslength fil))
(setq n 0)
(while (<= n (- len 1))                                        ;1
  (progn                                                        ;2
   (setq e (ssname fil n))
   (if (= "TEXT" (cdr (assoc 0 (setq ed (entget e)))))           ;3        过滤出文

本
     (progn                                                        ;4
  (setq et (cdr (assoc 1 (setq ed (entget e))))) ;********
  (setq ln (strlen et))
  (setq j 1)

  (while (< j ln)                                                 ;5
   (if (or (/= sc (substr et 1 j)) (= "0" (substr et (+ 1 j) 1)))        ;6
    (setq j (+ 1 j))
  (progn        ;7
  (setq i 1)                                                        
  (while (< i ln)                ;8 截取单管管长
    (setq tzh (substr et i 1))
     (if (= tzh "-")                 ;9
      (progn                         ;10
       (setq i (+ 1 i))
       (while (< i ln)                ;11
          (setq tzh2 (substr et i 1))
          (if (= tzh2 "-")        ;12
        (progn                        ;13
       (setq sm (substr et (+ i 1)))
      (setq sum (+ sum (atof sm)))
        ))                ;13,12
     (setq i (+ 1 i))
        )                        ;11
      )                                ;10
     (setq i (+ 1 i))
        )                        ;9 end if *        
   )                                ;接8
     (setq j (+ 1 j))
    )                                ;接7 progn
   )                                ;接6 if
   )                                ;接5 while

     )                        ;接4 progn
;    (setq n (+ 1 n))
    )                        ;接3 if
    (setq n (+ 1 n))
   )                        ;接2 progn
  )                        ;接1 while
(setq sumst (rtos sum 2))

(princ (strcat "\n\n\t\t totle 排水管径 " sc "= " sumst))

(princ)
)

zxq0220

eddy_dqiao 发表于 2014-11-11 15:17
运行提示参数错误，无法得到结果！

6楼改了，再试试。

iLisp

只要规则一样可以改成自动适应两种情况

eddy_dqiao

iLisp 发表于 2014-11-10 22:44
只要规则一样可以改成自动适应两种情况

能帮忙改下吗？

st788796

是这样标 DN300(管径)-30(管长)-3(坡度)
还是  DN300-30-3
仅对没有括号内容的标注

1. (defun c:tt (/ e dn lst ss x1 x2 tf)
   
2.   (if
   
3.     (and (setq e (car (xdrx_entsel "\n拾取统计管径文字: " '((1 . "DN###*")))))
   
4.          (progn
   
5.            (setq dn (car (xdrx_string_split
   
6.                            (xdrx_getpropertyvalue e "textstring")
   
7.                            "-"
   
8.                          )
   
9.                     )
   
10.            )
    
11.            (princ "\n选择统计范围<回车全选>...")
    
12.            (if (setq ss (ssget (list (cons 1 (strcat dn "`*")))))
    
13.              ss
    
14.              (setq ss (ssget "x" (list (cons 1 (strcat dn "`*")))))
    
15.            )
    
16.          )
    
17.     )
    
18.      (progn
    
19.        (setq
    
20.          lst (mapcar '(lambda (x)
    
21.                         (cdr (xdrx_string_split
    
22.                                (xdrx_getpropertyvalue x "textstring")
    
23.                                "-"
    
24.                              )
    
25.                         )
    
26.                       )
    
27.                      (xdrx_pickset->ents ss)
    
28.              )
    
29.          x1  (mapcar 'car lst)
    
30.          x2  (mapcar 'cadr lst)
    
31.          tf  (vl-some '> x1 x2)
    
32.        )
    
33.        (if tf
    
34.          (setq len (apply '+ (mapcar 'distof x1)))
    
35.          (setq len (apply '+ (mapcar 'distof x2)))
    
36.        )
    
37.        (princ
    
38.          (strcat "\n\n\t\t Totle 排水管径 " dn " = " (rtos len))
    
39.        )
    
40.      )
    
41.   )
    
42.   (princ)
    
43. )

(defun c:tt (/ e dn lst ss x1 x2 tf)<br />   (if<br />     (and (setq e (car (xdrx_entsel "\n拾取统计管径文字: " '((1 . "DN###*")))))<br />          (progn<br />            (setq dn (car (xdrx_string_split<br />                            (xdrx_getpropertyvalue e "textstring")<br />                            "-"<br />                          )<br />                     )<br />            )<br />            (princ "\n选择统计范围<回车全选>...")<br />            (if (setq ss (ssget (list (cons 1 (strcat dn "`*")))))<br />              ss<br />              (setq ss (ssget "x" (list (cons 1 (strcat dn "`*")))))<br />            )<br />          )<br />     )<br />      (progn<br />        (setq<br />          lst (mapcar '(lambda (x)<br />                         (cdr (xdrx_string_split<br />                                (xdrx_getpropertyvalue x "textstring")<br />                                "-"<br />                              )<br />                         )<br />                       )<br />                      (xdrx_pickset->ents ss)<br />              )<br />          x1  (mapcar 'car lst)<br />          x2  (mapcar 'cadr lst)<br />          tf  (vl-some '> x1 x2)<br />        )<br />        (if tf<br />          (setq len (apply '+ (mapcar 'distof x1)))<br />          (setq len (apply '+ (mapcar 'distof x2)))<br />        )<br />        (princ<br />          (strcat "\n\n\t\t Totle 排水管径 " dn " = " (rtos len))<br />        )<br />      )<br />   )<br />   (princ)<br /> )

eddy_dqiao

st788796 发表于 2014-11-11 08:23
是这样标 DN300(管径)-30(管长)-3(坡度)
还是  DN300-30-3

DN300-30-3,，管长和坡度还有可能带小数，谢谢！

zxq0220

eddy_dqiao 发表于 2014-11-11 02:36
能帮忙改下吗？

2. 
   
3. (defun c:tps (/ dat datlst dnlst fil ed et)
   
4. (setvar "CMDECHO" 0)
   
5. (setq datlst (list))
   
6. (setq fil (ssget '((0 . "TEXT")(1 . "DN#*-#*-#*"))));取文本中符合DN***-**-***字串
   
7. (repeat (setq i (sslength fil))
   
8.   (setq ed (entget(ssname fil (setq i (1- i)))))
   
9.   (setq et (cdr (assoc 1 ed)))
   
10.   (setq dat (read(strcat "(" (vl-string-translate "-" " " et) ")"))) ;(DN*** ** **)
    
11.   (setq datlst (cons dat datlst))
    
12. )
    
13. (setq datlst (vl-sort datlst
    
14. '(lambda (a b) (< (vl-princ-to-string (car a)) (vl-princ-to-string (car b))))));排序
    
15. (setq dnlst (list))
    
16. (foreach x datlst
    
17.   (if (not(member (car x) dnlst)) (progn
    
18.    (setq dnlst (cons (car x) dnlst));(DN*** ...)
    
19.    (set (car x) 0.0)
    
20.   ))
    
21.   (set (car x) (+ (apply 'max (cdr x)) (eval(car x))));取大值加入DN***
    
22. )
    
23. (foreach x (reverse dnlst)
    
24.   (write-line (strcat "\n\n\t\t totle 排水管径 " (vl-princ-to-string x) " = " (rtos(eval x))))
    
25. )
    
26. (setvar "CMDECHO" 1)
    
27. (princ)
    
28. )
    

<br /> (defun c:tps (/ dat datlst dnlst fil ed et) <br /> (setvar "CMDECHO" 0)<br /> (setq datlst (list))<br /> (setq fil (ssget '((0 . "TEXT")(1 . "DN#*-#*-#*"))));取文本中符合DN***-**-***字串<br /> (repeat (setq i (sslength fil))<br />   (setq ed (entget(ssname fil (setq i (1- i)))))<br />   (setq et (cdr (assoc 1 ed)))<br />   (setq dat (read(strcat "(" (vl-string-translate "-" " " et) ")"))) ;(DN*** ** **)<br />   (setq datlst (cons dat datlst))<br /> )<br /> (setq datlst (vl-sort datlst<br /> '(lambda (a b) (< (vl-princ-to-string (car a)) (vl-princ-to-string (car b))))));排序<br /> (setq dnlst (list))<br /> (foreach x datlst<br />   (if (not(member (car x) dnlst)) (progn<br />    (setq dnlst (cons (car x) dnlst));(DN*** ...)<br />    (set (car x) 0.0)<br />   ))<br />   (set (car x) (+ (apply 'max (cdr x)) (eval(car x))));取大值加入DN***<br /> )<br /> (foreach x (reverse dnlst)<br />   (write-line (strcat "\n\n\t\t totle 排水管径 " (vl-princ-to-string x) " = " (rtos(eval x))))<br /> )<br /> (setvar "CMDECHO" 1)<br /> (princ)<br /> )<br />

eddy_dqiao

zxq0220 发表于 2014-11-11 09:11

运行提示参数错误，无法得到结果！

eddy_dqiao

st788796 发表于 2014-11-11 08:23
是这样标 DN300(管径)-30(管长)-3(坡度)
还是  DN300-30-3
仅对没有括号内容的标注

程序运行 提示——错误: no function definition: XDRX_PICKSET->ENTS

csharp

eddy_dqiao 发表于 2014-11-11 15:20
程序运行 提示——错误: no function definition: XDRX_PICKSET->ENTS

这是 XDRXAPI 中定义函数，置顶帖子下载，然后 appload

eddy_dqiao

csharp 发表于 2014-11-11 15:27
这是 XDRXAPI 中定义函数，置顶帖子下载，然后 appload

还是不行，不能使用，选择也很困难，请大神打开附件里面的那张cad图会比较清楚，附件里面的lsp是我原来贴的代码文件，那个是可以正常运行的！

st788796

eddy_dqiao 发表于 2014-11-11 15:40
还是不行，不能使用，选择也很困难，请大神打开附件里面的那张cad图会比较清楚，附件里面的lsp是我原来贴 ...

1. (defun c:tt (/ e lst ss el)
   
2.   (if
   
3.     (and
   
4.       (setq
   
5.         e (car (xdrx_entsel "\n拾取管径标注: " '((1 . "DN*"))))
   
6.       )
   
7.       (progn
   
8.         (princ "\n选择统计范围<回车全选>...")
   
9.         (setq el (entget e))
   
10.         (if (setq
    
11.               ss (ssget (list '(0 . "text") (assoc 8 el) '(1 . "DN*")))
    
12.             )
    
13.           ss
    
14.           (setq        ss
    
15.                  (ssget "x" (list '(0 . "text") (assoc 8 el) '(1 . "DN*")))
    
16.           )
    
17.         )
    
18.       )
    
19.     )
    
20.      (progn
    
21.        (setq
    
22.          lst (mapcar '(lambda (x)
    
23.                         (xdrx_string_split
    
24.                           (xdrx_getpropertyvalue x "textstring")
    
25.                           "-"
    
26.                         )
    
27.                       )
    
28.                      (xdrx_pickset->ents ss)
    
29.              )
    
30.          lst (xd::list:groupbyindex lst 0)
    
31.        )
    
32.        (mapcar
    
33.          '(lambda (x / x1 x2 len tf dn)
    
34.             (setq dn (car x)
    
35.                   x1 (mapcar 'distof (mapcar 'car (cdr x)))
    
36.                   x2 (mapcar 'distof (mapcar 'cadr (cdr x)))
    
37.                   tf (vl-some '(lambda (a b) (> a b))
    
38.                               x1
    
39.                               x2
    
40.                      );_管长数字大于管径数字
    
41.             )
    
42.             (if        tf
    
43.               (setq len (apply '+ x1))
    
44.               (setq len (apply '+ x2))
    
45.             )
    
46.             (princ
    
47.               (strcat "\n\n\t\t Totle 排水管径 " dn " = " (rtos len))
    
48.             )
    
49.           )
    
50.          lst
    
51.        )
    
52.      )
    
53.   )
    
54.   (princ)
    
55. )
    

(defun c:tt (/ e lst ss el)<br />   (if<br />     (and<br />       (setq<br />         e (car (xdrx_entsel "\n拾取管径标注: " '((1 . "DN*"))))<br />       )<br />       (progn<br />         (princ "\n选择统计范围<回车全选>...")<br />         (setq el (entget e))<br />         (if (setq<br />               ss (ssget (list '(0 . "text") (assoc 8 el) '(1 . "DN*")))<br />             )<br />           ss<br />           (setq        ss<br />                  (ssget "x" (list '(0 . "text") (assoc 8 el) '(1 . "DN*")))<br />           )<br />         )<br />       )<br />     )<br />      (progn<br />        (setq<br />          lst (mapcar '(lambda (x)<br />                         (xdrx_string_split<br />                           (xdrx_getpropertyvalue x "textstring")<br />                           "-"<br />                         )<br />                       )<br />                      (xdrx_pickset->ents ss)<br />              )<br />          lst (xd::list:groupbyindex lst 0)<br />        )<br />        (mapcar<br />          '(lambda (x / x1 x2 len tf dn)<br />             (setq dn (car x)<br />                   x1 (mapcar 'distof (mapcar 'car (cdr x)))<br />                   x2 (mapcar 'distof (mapcar 'cadr (cdr x)))<br />                   tf (vl-some '(lambda (a b) (> a b))<br />                               x1<br />                               x2<br />                      );_管长数字大于管径数字<br />             )<br />             (if        tf<br />               (setq len (apply '+ x1))<br />               (setq len (apply '+ x2))<br />             )<br />             (princ<br />               (strcat "\n\n\t\t Totle 排水管径 " dn " = " (rtos len))<br />             )<br />           )<br />          lst<br />        )<br />      )<br />   )<br />   (princ)<br /> )<br />

命令: tt
拾取管径标注:
选择统计范围<回车全选>...
选择对象: 指定对角点: 找到 7 个
选择对象:
    Totle 排水管径 DN500 = 20
    Totle 排水管径 DN400 = 90
    Totle 排水管径 DN300 = 60

命令: tt
拾取管径标注:
选择统计范围<回车全选>...
选择对象:
    Totle 排水管径 DN400 = 154
    Totle 排水管径 DN300 = 296

eddy_dqiao

st788796 发表于 2014-11-11 16:18
命令: tt
拾取管径标注:
选择统计范围...

不知道怎么回事，cad2004开图，先加载XDRx2004.arx,再加载tt.lsp,运行，最后全选标注文字后，显示“错误: no function definition: XD::LIST:GROUPBYINDEX”
不知道是不是晓东函数加载有问题，加载后F2显示“欢迎来到晓东家园！！自启动LISP请在XDRx.lsp中定制.; 错误: LOAD 失败:
"C:\\Users\\Administrator\\Desktop\\XDsoft\\XDRx.18\\xd-lisp-lib.vlx"貌似没有下载晓东的函数库，我现在权限不够，下载不了，这个lisp能单独使用不依赖晓东函数吗？{:soso_e183:}

XDSoft

eddy_dqiao 发表于 2014-11-11 17:35
不知道怎么回事，cad2004开图，先加载XDRx2004.arx,再加载tt.lsp,运行，最后全选标注文字后，显示“错误: ...

你还需要加载 XD LISP函数库，论坛上的大部分程序，你只要加载了这两个基础的库，基本都能用了。

eddy_dqiao

XDSoft 发表于 2014-11-11 17:57
你还需要加载 XD LISP函数库，论坛上的大部分程序，你只要加载了这两个基础的库，基本都能用了。

版主，函数库我的权限不够，下载不了啊！有什么办法吗？

XDSoft

eddy_dqiao 发表于 2014-11-11 18:02
版主，函数库我的权限不够，下载不了啊！有什么办法吗？

50个积分，快了。
如果你有什么好的资料发上来，给你加分，你就更快了。

另外，函数库所有的源码，都在开源函数库论坛，你可以去搜索下程序里面需要的XD::开头的函数，拷贝回去用。