本帖最后由 革天明 于 2012-7-10 14:42 编辑
因为红色的在CC图层，我排除掉了，
(defun c:test1 ()(vl-load-com)
;;以下用于将MTEXT中的格式符去掉====================================================
;;mccad http://bbs.mjtd.com/forum.php?mod=viewthread&tid=57445
(defun mtext2text (MTextString / regex s)
(setq regex (vlax-create-object "Vbscript.RegExp"))
;引用正则表达式控件
(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
(vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配
(setq s MTextString)
;替换\\字符
(vlax-put-property regex "Pattern" "\\\\\\\\")
(setq s (vlax-invoke-method regex "Replace" s (chr 1)))
;替换\{字符
(vlax-put-property regex "Pattern" "\\\\{")
(setq s (vlax-invoke-method regex "Replace" s (chr 2)))
;替换\}字符
(vlax-put-property regex "Pattern" "\\\\}")
(setq s (vlax-invoke-method regex "Replace" s (chr 3)))
;删除段落缩进格式
(vlax-put-property regex "Pattern" "\\\\pi(.[^;]*);")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除制表符格式
(vlax-put-property regex "Pattern" "\\\\pt(.[^;]*);")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除堆迭格式
(vlax-put-property
regex
"Pattern"
"\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
(vlax-put-property
regex
"Pattern"
"(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除下划线、删除线格式
(vlax-put-property
regex
"Pattern"
"(\\\\L|\\\\O|\\\\l|\\\\o)"
)
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除不间断空格格式
(vlax-put-property regex "Pattern" "\\\\~")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除换行符格式
(vlax-put-property regex "Pattern" "\\\\P")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除换行符格式(针对Shift+Enter格式)
(vlax-put-property regex "Pattern" "\n")
(setq s (vlax-invoke-method regex "Replace" s ""))
;删除{}
(vlax-put-property regex "Pattern" "({|})")
(setq s (vlax-invoke-method regex "Replace" s ""))
;替换回\\,\{,\}字符
(vlax-put-property regex "Pattern" "\\x01")
(setq s (vlax-invoke-method regex "Replace" s "\\"))
(vlax-put-property regex "Pattern" "\\x02")
(setq s (vlax-invoke-method regex "Replace" s "{"))
(vlax-put-property regex "Pattern" "\\x03")
(setq s (vlax-invoke-method regex "Replace" s "}"))
(vlax-release-object regex)
s
) ;end defun mtext2text
;;按指定分割符将字符串分割成表=======================================================
;;++++++++++++++++++
;;parser by CAB
;;Http://discussion.autodesk.com/f ... dID=759125&tstart=0
;;http://bbs.mjtd.com/forum.php?mo ... 24&page=1#pid422330
;;++++++++++++++++++
(defun sparser (str delim / ptr lst)
(while (setq ptr (vl-string-search delim str))
(setq lst (cons (substr str 1 ptr) lst))
(setq str (substr str (+ ptr 2)))
)
(reverse (cons str lst))
)
(setq ss (ssget '((0 . "text,mtext")
(-4 . "<NOT")
(8 . "cc")
(-4 . "NOT>")
)
)
)
(setq i 0
str ""
)
(repeat (sslength ss)
(setq str1 (vl-string-left-trim
" "
(vl-string-right-trim
" "
(mtext2text (cdr (assoc 1 (entget (ssname ss i)))))
)
)
)
(setq str
(strcat str "@" str1)
)
(setq i (1+ i))
) ;end repeat
(setq strlst (sparser (substr str 2) "@"))
(setq i 0
silvernum 0
silversum 0
silvyynum 0
silvyysum 0
diamondsum
0
diamondnum
0
moneynum 0
moneysum 0
)
(foreach x strlst
(cond ((vl-string-search "silver" x)
(progn
(setq silvernum (1+ silvernum))
(setq silversum (+ silversum (atof (substr x 8))))
)
)
((vl-string-search "silvyy" x)
(progn
(setq silvyynum (1+ silvyynum))
(setq silvyysum (+ silvyysum (atof (substr x 8))))
)
)
((vl-string-search "diamond" x)
(progn
(setq diamondnum (1+ diamondnum))
(setq diamondsum (+ diamondsum (atof (substr x 9))))
)
)
((vl-string-search "money" x)
(progn
(setq moneynum (1+ moneynum))
(setq moneysum (+ moneysum (atof (substr x 7))))
)
)
(t (princ "\n有其它字符串"))
)
;;end cond
) ;end foreach
(setq f1 (getfiled "指定输出文件路径" "" "xls" 1)
f1 (open f1 "w")
)
(write-line "项目\t数目\t和" f1)
(if (> silversum 0)
(progn
(setq txt1 (strcat "silver\t"
(rtos silvernum 2 2)
"\t"
(rtos silversum 2 2)
)
)
(write-line txt1 f1)
)
)
(if (> silvyysum 0)
(progn
(setq txt2 (strcat "silvyy\t"
(rtos silvyynum 2 2)
"\t"
(rtos silvyysum 2 2)
)
)
(write-line txt2 f1)
)
)
(if (> diamondsum 0)
(progn
(setq txt3 (strcat "diamond\t"
(rtos diamondnum 2 2)
"\t"
(rtos diamondsum 2 2)
)
)
(write-line txt3 f1)
)
)
(if (> moneysum 0)
(progn
(setq txt4
(strcat "money\t"
(rtos moneynum 2 2)
"\t"
(rtos moneysum 2 2)
)
)
(write-line txt4 f1)
)
)
(close f1)
)
先坐沙发，友情顶一下
本帖最后由 革天明 于 2012-5-14 17:38 编辑
占位，尝试一下
测试通过
silver共3个,和为1621.96
silvyy共2个,和为25.96
diamond共4个,和为3217.96
money共2个,和为10
你上传的那个版本太高，我打不开，同时你要说明 silver 999那个在那个图层上，不然不能过滤
写的很好！去年找了很久了
whoami3340a 发表于 2012-7-6 09:39 static/image/common/back.gif
前段时间忙，没上线，不好意思
能达到你的要求吗？有需要的话我还可以练练手
学习一下，，，
楼主没有兑现悬赏哦