将纯数字字符翻译成汉字数字

gbhsu

;;;本人原创:将纯数字转变为汉字数字字符
;;;快过中秋了,给大家送点小礼物
;;;原想将cmd+num升级版发出来的,由于工作量大,且要增加不少命令
;;;看来是来不及了
;;;现将前不久鼓捣的一个小子程贴出来大家讨论一下
;;;数字大了,可能有点小问题,正如林子大了,什么鸟都有一样
;;;大家帮忙赶一赶
;;;e.g.(hsu:num2ch "123")"一百二十三"
;;;因在cad中的数值文字是以字符的形式存在的
;;;测试命令为" tt" 专为戏男而编!
(defun c:tt(/ numstr)
        (setq numstr (getstring "\n请输入数字字符:"))
       (if  numstr (hsu:num2ch  numstr))
)

(defun hsu:num2ch(str / len strlist hzlist strch listi i j name)
       (vl-load-com)
       (setq len (strlen str)i 0 hzlist '()listi '())
       (setq strlist (reverse(VL-STRING->LIST str)))
  (while strlist
    (if (or(= i 4)(= i len))
        (progn
        (setq i 0)
        (setq hzlist (append (list listi) hzlist))
        (setq listi'())
        )
        (progn
        (setq i (+ i 1))
        (setq listi (append (list(car strlist)) listi))
        (setq strlist (cdr strlist))
        );progn
        );if
    );repeat
  (if listi (setq hzlist (append (list listi) hzlist)))
  (setq hzlist (reverse hzlist)i 0  strch "" name "")  
     ;hzlist
  (foreach n  hzlist
          (cond ((= i 1)(if(or
        (/=(nth 0 n)48)
        (/=(nth 1 n)48)
        (/=(nth 2 n)48)
        (/=(nth 3 n)48))
        (setq name "万")
        (setq name "零")))
                ((= i 2)(if(or
        (/=(nth 0 n)48)
        (/=(nth 1 n)48)
        (/=(nth 2 n)48)
        (/=(nth 3 n)48))
        (setq name "亿")
        (setq name "零")))
  
                ((= i 3)(if(or
        (/=(nth 0 n)48)
        (/=(nth 1 n)48)
        (/=(nth 2 n)48)
        (/=(nth 3 n)48))
        (setq name "兆")
        (setq name "零")))
  
     );cond
   (setq j i)  
          (setq strch (strcat  (hsu:num2hz n) name strch))
   (setq i (+ i 1))  
    );foreach
    (setq len (strlen strch))
    (if(=(substr strch 1 4 )"一十")(setq strch (substr strch 3)))
         (while (vl-string-search  "零零" strch)
                (setq strch(vl-string-subst "零""零零" strch)))  
     strch
  );defun
(defun hsu:num2hz(plist / string i)
      (vl-load-com)
      (setq i 0)
      (setq plist(reverse plist))
      (setq string '())
      (foreach n plist
        (setq string (append string
                            (list                             
         (cond
      ((= n 48)"零")               
      ((= n 49)"一")
      ((= n 50)"二")
      ((= n 51)"三")
      ((= n 52)"四")
      ((= n 53)"五")
      ((= n 54)"六")
      ((= n 55)"七")
      ((= n 56)"八")
      ((= n 57)"九")
      );cond
            
                                    (cond
                                    ((and(<= j 3)(= i 0))(if(/=(nth (+ i 1) plist)48)"十" ""))
        ((and(<= j 3)(= i 1))(if(/=(nth (+ i 1) plist)48)"百" ""))
        ((and(<= j 3)(= i 2))(if(/=(nth (+ i 1) plist)48)"千" ""))
                                    ((and(<= j 3)(= i 3))(if(/=(nth (+ i 1) plist)48)"万" ""))
                                    ((and(<= j 3)(= i 4))(if(/=(nth (+ i 1) plist)48)"亿" ""))
        ((and(<= j 3)(= i 5))(if(/=(nth (+ i 1) plist)48)"兆" ""))
        (if(> j 3)"")
               );cond
      
            
         );list
   );cond
       );setq
(setq i (+ i 1))
);foreach
        
  (while(or(eq(car string)"零")(eq(car string)""))(setq string(cdr string)))
  (setq string(apply 'strcat  (cdr (reverse string))))   
  );defun

hdlyt11

呵呵，真的不错哦，

gbhsu

呵呵,沙发有人抢了,自已坐板凳吧!

kwok

lsp功能真强大......

戏男

你真是个人才啊 这也能做得到

戏男

好象不行哦

gbhsu

戏男 发表于 2011-9-8 14:33
好象不行哦

_$ (hsu:num2ch "123456789")
"一亿二千三百四十五万六千七百八十九"
_$

哪里不行?
是不是少函数?

mandala

挺有意思的东西，支持。

lincctw_ccl

樓主真是太有才了!!
可惜這lsp我用不上
不然效率提高是可期的

戏男

我试了那个命令 不行啊num2ch 就这个命令