将指定图层下选中区域内的单行文字内的数字累加，并输出到excel

革天明

因为红色的在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)
)

puzb2001

先坐沙发，友情顶一下

革天明

占位，尝试一下
测试通过
silver共3个,和为1621.96
silvyy共2个,和为25.96
diamond共4个,和为3217.96
money共2个,和为10
你上传的那个版本太高，我打不开，同时你要说明 silver 999那个在那个图层上，不然不能过滤

dcl1214

写的很好！去年找了很久了

革天明

whoami3340a 发表于 2012-7-6 09:39
前段时间忙，没上线，不好意思

能达到你的要求吗？有需要的话我还可以练练手

xiabin68

学习一下，，，

langjs

楼主没有兑现悬赏哦