[LISP程序]：文本求和xtcal程序，支持文本中多个数字

陌生人 · 发表于 2004-1-4 21:01:07

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

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

×

文本数字求和xtcal程序
对选集中文本进行所有数字计算（支持选择集）,支持text,mtext中有多个数字字符串,支持字符串中小数,负数:
;;返回: 如文本中有数字，数字相加后写文本，并返回求和数值(非字符串).无有效数字返回nil.
;;注意:文本中的数字必须为正常格式,对 3.2.1 返回错误结果(＝3),对 . . 2.1 两个以上连续点返回错误. --1.6 不能连负号.

(defun xtcal ( / ss filter mspace n e str asclst strs add pt txt txth)
(defun *error* (msg) (if ss (x_draw ss 4)) (setq *error* oerr))
(princ "\n文本数字求和－－－－－－－－－－－－－－－－－－－－－－－陌生人.2004.1")
(princ "\n选择要计算的文本(支持*TEXT选择集):")
(setq oerr *error*
ss (ssget '((0 . "*TEXT")))
filter "0123456789.-+"
mspace (vla-get-modelspace(vla-get-activedocument (vlax-get-acad-object)))
str nil strs nil)
(if ss
(repeat (setq n (sslength ss))
(x_draw ss 3)
(setq n (1- n)
e (ssname ss n)
str (vla-get-textstring(vlax-ename->vla-object e))
asclst (mapcar '(lambda (x) (if (vl-string-search (chr x) filter) x 32)) (vl-string->list str))
strs (strcat (if strs strs " ") (apply 'strcat (mapcar 'chr asclst)) " "))
)
)
(if (and ss (/= "" strs))
(progn
(setq add (eval (read (strcat "(+ " strs ")"))))
(princ "\n文本数字和为: ")(princ add)
(if (setq pt (getpoint "\n标注位置<重新计算>:"))
(progn
(setq prec (getint "\n精度(小数位数):")
txt (rtos add 2 prec)
txth (getdist "\n字高:"))
(vla-addtext mspace txt (vlax-3D-point pt) txth)
(x_draw ss 4)
(princ) add)
(progn (if ss (x_draw ss 4))(xtcal));多次<重新计算>可以作为一个简易统计查看器.
)
)
(progn (princ "\n!空选集或文本中无有效数字!\n") nil)
)
)
;;配套程序(x_draw ss key)
(defun x_draw (ss key / n e)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(setq n (1- n)
e (ssname ss n))
(redraw e key)
)
)
)

(defun xtcal ( / ss filter mspace n e str asclst strs add pt txt txth) 
  (defun *error* (msg) (if ss (x_draw ss 4)) (setq *error* oerr)) 
  (princ "\n文本数字求和－－－－－－－－－－－－－－－－－－－－－－－陌生人.2004.1") 
  (princ "\n选择要计算的文本(支持*TEXT选择集):") 
  (setq oerr *error* 
        ss (ssget '((0 . "*TEXT"))) 
        filter "0123456789.-+" 
        mspace (vla-get-modelspace(vla-get-activedocument (vlax-get-acad-object))) 
        str nil strs nil) 
  (if ss 
    (repeat (setq n (sslength ss)) 
      (x_draw ss 3) 
      (setq n (1- n) 
            e (ssname ss n) 
            str (vla-get-textstring(vlax-ename->vla-object e)) 
            asclst (mapcar '(lambda (x) (if (vl-string-search  (chr x) filter) x 32)) (vl-string->list str)) 
            strs (strcat (if strs strs " ") (apply 'strcat (mapcar 'chr asclst)) " ")) 
      ) 
    ) 
  (if (and ss (/= "" strs)) 
    (progn 
      (setq add (eval (read (strcat "(+ " strs ")")))) 
      (princ "\n文本数字和为: ")(princ add) 
      (if (setq pt (getpoint "\n标注位置<重新计算>:")) 
          (progn 
            (setq prec (getint "\n精度(小数位数):") 
                  txt (rtos add 2 prec) 
                  txth (getdist "\n字高:")) 
            (vla-addtext mspace txt (vlax-3D-point pt) txth) 
            (x_draw ss 4) 
            (princ) add) 
         (progn (if ss (x_draw ss 4))(xtcal));多次<重新计算>可以作为一个简易统计查看器. 
      ) 
    ) 
    (progn (princ "\n!空选集或文本中无有效数字!\n") nil) 
  ) 
) 
;;配套程序(x_draw ss key) 
(defun x_draw (ss key / n e) 
  (if (= 'PICKSET (type ss)) 
    (repeat (setq n (sslength ss)) 
      (setq n (1- n) 
            e (ssname ss n)) 
      (redraw e key) 
    ) 
  ) 
)

其实取得数字文本的语句很简短，就是
(if ss
(repeat (setq n (sslength ss))
 (setq n (1- n)
 e (ssname ss n)
 str (vla-get-textstring(vlax-ename->vla-object e))
 asclst (mapcar '(lambda (x) (if (vl-string-search (chr x) filter) x 32)) (vl-string->list str))
 strs (strcat (if strs strs " ") (apply 'strcat (mapcar 'chr asclst)) " ")) )
)

测试:
(xtcal)
选择要计算的文本(支持*TEXT选择集):
Select objects: 1 found
Select objects: Specify opposite corner: 1 found, 2 total
Select objects:
 (注明:此时选中两个文本 "afsda 234.5 暗暗-558.9啊 ab " 和 "-1622.000")
文本数字和为: -1946.4 (注: 234.5-558.9-1622.000=-1946.4)
标注位置<重新计算>:
精度(小数位数):3
字高: Specify second point: -1946.4 (注:-1946.4为返回值)

<embed src=http://www.xdcad.net/techcenter/upload/file/74488_20040104212511_tech.swf quality=high width=900 height=700 loop=true type="application/x-shockwave-flash">
</embed>

zuicai · 发表于 2004-1-4 21:37:48

你给的SWF文件下载链接怎么是美女头像啊？

现在的正常了，刚才不知是什么问题。

陌生人 · 发表于 2004-1-4 21:41:17

程序下载
演示作的有点快。可按暂停对比演示中计算结果是否正确。

程序已经更新。

陌生人 · 发表于 2004-1-4 21:42:04

最初由 zuicai 发布
[B]你给的SWF文件下载链接怎么是美女头像啊？ [/B]

弄错了。已经更新

snsj · 发表于 2004-1-4 22:05:27

我测试用：所所扶绥发300.2
拷贝了三个计算结果是1464.6，你试试你那里是不是正常

陌生人 · 发表于 2004-1-4 22:32:38

Command: (xtcal)

文本数字求和－－－－－－－－－－－－－－－－－－－－－－－陌生人.2004.1
选择要计算的文本(支持*TEXT选择集):
Select objects: Specify opposite corner: 3 found

Select objects:

文本数字和为: 900.6
标注位置<重新计算>:
精度(小数位数):3

字高:3
900.6

我这里正常,不知道你那里是什么原因。是不是多选了其他文本？

!!!!!!注意，程序已经更新。加入对选集亮显以更能看清所选文本。并加入出错处理.!!!!!

aeo · 发表于 2004-1-5 01:35:41

前面有讨论的.
用的是wcmatch
找找吧.

陌生人 · 发表于 2004-1-5 11:08:29

注意，现发现mtext计算有错误，因为把格式符号如 |134 ...也当做数字计算进去了。忙，过两天改写。或者哪位有兴趣的可以完善。

已经解决mtext计数bug。－－2004.1.17

[color=blue]
;|(xtcal)= 文本计数求和;----------------------------------------------------------------陌生人.2004.1
;v1.1 2004.1.对mtext的bug修正。消除重复符号;支持-.5写法,排除"写.法" ".." "+-";
功能：对选集中文本进行所有数字计算,支持一个text,mtext中有多个数字字符串,支持字符串中小数,负数:
返回: 有数字，数字相加后写文本，并返回求和数值(非字符串).无有效数字返回nil.
|;[/color]
(defun xtcal ( / ss filter mspace n e str asclst strs add pt txt txth)
(defun *error* (msg) (if ss (x_draw ss 4)) (setq *error* oerr))
(princ "\n文本数字求和－－－－－－－－－－－－－－－－－－－－－－－陌生人.2004.1")
(princ "\n选择要计算的文本(支持*TEXT选择集):")
(setq oerr *error*
ss (ssget '((0 . "*TEXT")))
filter "0123456789.-+"
mspace (vla-get-modelspace(vla-get-activedocument (vlax-get-acad-object)))
str nil strs nil)
(if ss
(repeat (setq n (sslength ss))
(x_draw ss 3)
(setq n (1- n)
e (ssname ss n)
str (vla-get-textstring(vlax-ename->vla-object e))
strs (strcat (if strs strs " ") (x_txt2 str) " ")) [color=blue];;排除mtext bug.v1.1-2004.1[/color]
)
)
(if (and ss (/= "" strs))
(progn
(setq add (eval (read (strcat "(+ " strs ")"))))
(princ "\n文本数字和为: ")(princ add)
(if (setq pt (getpoint "\n标注位置<重新计算>:"))
(progn
(setq prec (getint "\n精度(小数位数):")
txt (rtos add 2 prec)
txth (getdist "\n字高:"))
(vla-addtext mspace txt (vlax-3D-point pt) txth)
(x_draw ss 4)
(princ) add)
(progn (if ss (x_draw ss 4))(xtcal)) ;多次<重新计算>可以作为一个简易统计查看器.
)
)
(progn (princ "\n!空选集或文本中无有效数字!\n") nil)
)
)
;;
(defun x_draw (ss key / n e)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(setq n (1- n)
e (ssname ss n))
(redraw e key)
)
)
)
;;
(defun x_txt2 (str / i key str1)
(setq i 1)
(repeat (strlen str)
(cond
((= "{\\f" (substr str i 3)) (setq i (+ 3 i) key T))
((and T (= "}" (substr str i 1))) (setq key nil))
((not key)
(setq st (substr str i 1)
str1 (strcat (if (not str1) "" str1)
(cond ((= "." st)(if (wcmatch (substr str (1+ i) 1) "#") st " "))
((member st '("+" "-")) (if (wcmatch (substr str (1+ i) 1) "#,'.") st " "))
(T (if (wcmatch filter (strcat "*" st "*")) st " "))
)
)))
)
(setq i (1+ i))
)
(setq str str1)
)

[color=blue] 
;|(xtcal)= 文本计数求和;----------------------------------------------------------------陌生人.2004.1 
;v1.1 2004.1.对mtext的bug修正。消除重复符号;支持-.5写法,排除"写.法" ".." "+-"; 
功能：对选集中文本进行所有数字计算,支持一个text,mtext中有多个数字字符串,支持字符串中小数,负数: 
返回: 有数字，数字相加后写文本，并返回求和数值(非字符串).无有效数字返回nil. 
|;[/color] 
(defun xtcal ( / ss filter mspace n e str asclst strs add pt txt txth) 
  (defun *error* (msg) (if ss (x_draw ss 4)) (setq *error* oerr)) 
  (princ "\n文本数字求和－－－－－－－－－－－－－－－－－－－－－－－陌生人.2004.1") 
  (princ "\n选择要计算的文本(支持*TEXT选择集):") 
  (setq oerr *error* 
        ss (ssget '((0 . "*TEXT"))) 
        filter "0123456789.-+" 
        mspace (vla-get-modelspace(vla-get-activedocument (vlax-get-acad-object))) 
        str nil strs nil) 
  (if ss 
    (repeat (setq n (sslength ss)) 
      (x_draw ss 3) 
      (setq n (1- n) 
            e (ssname ss n) 
            str (vla-get-textstring(vlax-ename->vla-object e)) 
            strs (strcat (if strs strs " ") (x_txt2 str) " ")) [color=blue];;排除mtext bug.v1.1-2004.1[/color] 
      ) 
    ) 
  (if (and ss (/= "" strs)) 
    (progn 
      (setq add (eval (read (strcat "(+ " strs ")")))) 
      (princ "\n文本数字和为: ")(princ add) 
      (if (setq pt (getpoint "\n标注位置<重新计算>:")) 
          (progn 
            (setq prec (getint "\n精度(小数位数):") 
                  txt (rtos add 2 prec) 
                  txth (getdist "\n字高:")) 
            (vla-addtext mspace txt (vlax-3D-point pt) txth) 
            (x_draw ss 4) 
            (princ) add) 
          (progn (if ss (x_draw ss 4))(xtcal))  ;多次<重新计算>可以作为一个简易统计查看器. 
      ) 
    ) 
    (progn (princ "\n!空选集或文本中无有效数字!\n") nil) 
  ) 
) 
;; 
(defun x_draw (ss key / n e) 
  (if (= 'PICKSET (type ss)) 
    (repeat (setq n (sslength ss)) 
      (setq n (1- n) 
            e (ssname ss n)) 
      (redraw e key) 
    ) 
  ) 
) 
;; 
(defun x_txt2 (str / i key str1) 
  (setq i 1) 
  (repeat (strlen str) 
   (cond 
     ((= "{\\f" (substr str i 3)) (setq i (+ 3 i) key T)) 
     ((and T (= "}" (substr str i 1))) (setq key nil))    
     ((not key) 
      (setq st (substr str i 1) 
            str1 (strcat (if (not str1) "" str1) 
      (cond ((= "." st)(if (wcmatch (substr str (1+ i) 1) "#") st " ")) 
                               ((member st '("+" "-")) (if (wcmatch (substr str (1+ i) 1) "#,'.") st " ")) 
                               (T (if (wcmatch filter (strcat "*" st "*")) st " ")) 
                         ) 
                         ))) 
   ) 
   (setq i (1+ i)) 
  ) 
  (setq str str1) 
)

guanhuaming · 发表于 2004-1-30 09:46:18

非常感谢谢，真的好好用。越来越喜欢这里了。

841594 · 发表于 2004-2-2 13:31:45

陌生人：
我试了一下这个程序，发现还有bug。因为mtext的文字内容可能是下面这样的：
{\f@黑体|b0|i0|c134|p2;1324qrq324}
注意，分号后面的是有效的文字！

把x_txt段的代码改了一下：

(defun x_txt2 (str / i key1 key2 str1)
  (setq i 1 key2 nil)
  (repeat (strlen str)
(cond
   ((= "{\\f" (substr str i 3)) (setq i (+ 3 i) key1 1 key2 1))
   ((and key1 (= "}" (substr str i 1))) (setq key1 nil key2 nil))
   ((and key1 (= ";" (substr str i 1))) (setq key2 nil))
   ((not key2)
   (setq st (substr str i 1)
         str1 (strcat (if (not str1) "" str1)
   (cond
((= "." st)(if (wcmatch (substr str (1+ i) 1) "#") st " "))
((member st '("+" "-")) (if (wcmatch (substr str (1+ i) 1) "#,'.") st " "))
(T (if (wcmatch filter (strcat "*" st "*")) st " "))
   )
))
   )
)
(setq i (1+ i))
  )
  (setq str str1)
)

狗尾续貂，见笑了。

陌生人 · 发表于 2004-2-2 19:49:08

谢谢，确实疏忽了。应该以；号结束过滤
另外，本程序代码不够精简，拟近期重写一遍

snsj · 发表于 2004-2-5 11:30:07

注意数字的字体为中文字体的情况

ywx0576 · 发表于 2004-2-8 20:27:35

如果能对尺寸标注求就更好了。

snsj · 发表于 2004-2-8 21:09:43

最初由 ywx0576 发布
[B]如果能对尺寸标注求就更好了。 [/B]

求标注和容易，文字求和中的MTEXT构造稍微复杂些

;;;标注求和
(defun c:qbz (/ ss kk i)
(setq ss (ssget '((0 . "DIMENSION"))) i 0 kk nil)
(repeat (sslength ss)
(setq kk (cons (cdr(assoc 42(entget(ssname ss i)))) kk))
(setq i (1+ i))
)
(princ "\n******所选标注和为")(princ (apply '+ kk))(princ "******")
(princ)
)

ywx0576 · 发表于 2004-2-25 12:33:10

snsj斑竹的程序对于默认的标注值，求和结果正确。
但是对于人为改过的标注值，求和结果并不是标注值之和。
请斑竹改正，谢谢!

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

[LISP程序]：文本求和xtcal程序，支持文本中多个数字

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

相关帖子