[不死猫出品] VBA-LISP 代码转换工具（源码）

nonsmall

大家好！
好久没发东西了，今天翻箱底发现这个，拿上来与大伙分享
原文思路在这里：
http://bbs.mjtd.com/thread-72391-1-1.html
完整源码收1个明经币

下面是部分源代码……

1. 
   
2. (defun vba(vba_str / p1 p2 vba_express vba_item vba_items vba_lst vba_num vba_object vba_ref vba_tmp)
   
3. (setq vba_lst (non_string_to_list vba_str "."))
   
4. (foreach vba_item vba_lst
   
5.   (cond
   
6.    ((= (strcase vba_item) "APP");根对象
   
7.     (setq vba_object (vlax-get-acad-object))
   
8.    )
   
9.    ((= (strcase vba_item) "THISDRAWING");当前图档
   
10.     (setq vba_object (vla-get-activedocument(vlax-get-acad-object)))
    
11.    )
    
12.    ((= vba_item (car vba_lst));获取对象
    
13.     (setq vba_object (eval (read vba_item)))
    
14.    )
    
15.    ((vl-string-search "ITEM" (strcase vba_item));集合中的vba_item处理
    
16.     (setq vba_tmp (non_string_to_list vba_item "("))
    
17.     (setq vba_item (car vba_tmp))
    
18.     (setq vba_item (vl-string-right-trim " " vba_item))
    
19.     (setq vba_num (read (vl-string-right-trim ")" (cadr vba_tmp))))
    
20.     (cond
    
21.      ((= (type vba_num) 'INT)
    
22.       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))
    
23.      )
    
24.      ((= (type vba_num) 'SYM)
    
25.       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))
    
26.      )
    
27.      ((= (type vba_num) 'STR)
    
28.       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))
    
29.      )
    
30.     )
    
31.     (setq vba_express (strcat "(setq vba_object (vla-item  vba_object " vba_num "))"))
    
32.     (if (vl-catch-all-error-p(vl-catch-all-apply 'eval (list (read vba_express))))
    
33.      (eval (read (strcat "(setq vba_object (vlax-get-property  vba_object 'item " vba_num "))")))
    
34.     )
    
35.    )
    
36. ((and (vl-string-position (ascii "(") vba_item);索引处理
    
37.     (setq p1 (vl-string-position (ascii "(") vba_item))
    
38.     (setq p2 (vl-string-position (ascii ")") vba_item))
    
39.     (numberp (eval (read (setq vba_num (substr vba_item (+ p1 2) (- p2 p1 1))))))
    
40.     )
    
41.     (setq vba_tmp (non_string_to_list vba_item "("))
    
42.     (setq vba_ref (car vba_tmp))
    
43.     (setq vba_ref (vl-string-right-trim " " vba_ref))   
    
44.     (if (vl-string-position (ascii "=") vba_item)
    
45.      (progn
    
46.       (setq vba_tmp (non_string_to_list vba_item "="))
    
47.       (eval (read (strcat "(setq vba_object (vlax-put-property vba_object '" vba_ref " " vba_num " " (cadr vba_tmp) "))")))
    
48.      )
    
49.      (eval (read (strcat "(setq vba_object (vlax-get-property vba_object '" vba_ref " " vba_num "))")))
    
50.     )
    
51.    )
    
52.   )
    
53. )
    
54. (cond
    
55.   ((= vba_object :vlax-true)
    
56.    T
    
57.   )
    
58.   ((= vba_object :vlax-false)
    
59.    nil
    
60.   )
    
61.   (T
    
62.    vba_object
    
63.   )
    
64. )
    
65. )
    

<br /> (defun vba(vba_str / p1 p2 vba_express vba_item vba_items vba_lst vba_num vba_object vba_ref vba_tmp)<br /> (setq vba_lst (non_string_to_list vba_str "."))<br /> (foreach vba_item vba_lst<br />   (cond<br />    ((= (strcase vba_item) "APP");根对象<br />     (setq vba_object (vlax-get-acad-object))<br />    )<br />    ((= (strcase vba_item) "THISDRAWING");当前图档<br />     (setq vba_object (vla-get-activedocument(vlax-get-acad-object)))<br />    )<br />    ((= vba_item (car vba_lst));获取对象<br />     (setq vba_object (eval (read vba_item)))<br />    )<br />    ((vl-string-search "ITEM" (strcase vba_item));集合中的vba_item处理<br />     (setq vba_tmp (non_string_to_list vba_item "("))<br />     (setq vba_item (car vba_tmp))<br />     (setq vba_item (vl-string-right-trim " " vba_item))<br />     (setq vba_num (read (vl-string-right-trim ")" (cadr vba_tmp))))<br />     (cond<br />      ((= (type vba_num) 'INT)<br />       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))<br />      )<br />      ((= (type vba_num) 'SYM)<br />       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))<br />      )<br />      ((= (type vba_num) 'STR)<br />       (setq vba_num (vl-string-right-trim ")" (cadr vba_tmp)))<br />      )<br />     )<br />     (setq vba_express (strcat "(setq vba_object (vla-item  vba_object " vba_num "))"))<br />     (if (vl-catch-all-error-p(vl-catch-all-apply 'eval (list (read vba_express))))<br />      (eval (read (strcat "(setq vba_object (vlax-get-property  vba_object 'item " vba_num "))")))<br />     )<br />    )<br /> ((and (vl-string-position (ascii "(") vba_item);索引处理<br />     (setq p1 (vl-string-position (ascii "(") vba_item))<br />     (setq p2 (vl-string-position (ascii ")") vba_item))<br />     (numberp (eval (read (setq vba_num (substr vba_item (+ p1 2) (- p2 p1 1))))))<br />     )<br />     (setq vba_tmp (non_string_to_list vba_item "("))<br />     (setq vba_ref (car vba_tmp))<br />     (setq vba_ref (vl-string-right-trim " " vba_ref))    <br />     (if (vl-string-position (ascii "=") vba_item)<br />      (progn<br />       (setq vba_tmp (non_string_to_list vba_item "="))<br />       (eval (read (strcat "(setq vba_object (vlax-put-property vba_object '" vba_ref " " vba_num " " (cadr vba_tmp) "))")))<br />      )<br />      (eval (read (strcat "(setq vba_object (vlax-get-property vba_object '" vba_ref " " vba_num "))")))<br />     )<br />    )<br />   )<br /> )<br /> (cond<br />   ((= vba_object :vlax-true)<br />    T<br />   )<br />   ((= vba_object :vlax-false)<br />    nil<br />   )<br />   (T<br />    vba_object<br />   )<br /> )<br /> )<br />

gbhsu

非常厉害的版主，学习了！
呵呵！

lee50310

奇怪了!   
下載後,載入程式 照樓主提供的方式執行 出現錯誤
(setq newlay (vba "layers.add(\"234\")"))
錯誤: 損壞的引數類型: VLA-OBJECT nil

(vba "lay.color=3")
; 錯誤: 損壞的引數類型: VLA-OBJECT nil

里皎相

很好很强大，最近在开发某些自己需要的功能，这个刚好可以学习各种转换的代码。

qcw911

猫猫发帖子啦~~~

nonsmall

额 好快的抢楼手法……

程序的返回值还是vlisp格式的 先转换而后执行 其他的代码？大家DIY好了

命令: (setq layers (vba "activedocument.layers"))
#<VLA-OBJECT IAcadLayers2 0266a7a4>
命令: (setq newlay (vba "layers.add(\"234\")"))
#<VLA-OBJECT IAcadLayer2 026b3844>
命令: (vba "newlay.color=6")
nil

命令: (setq lay(vba "activedocument.layers.add(\"111\")"))
#<VLA-OBJECT IAcadLayer2 026b4954>
命令: (vba "lay.color=3")
nil
命令: (vba "activedocument.layers.item(\"111\").color=1")
nil

zhynt

挖个坑蹲着。

tm20038175

使用这个操控excel岂不是很方便了？

仲文玉

支持猫猫工具，

xq4u

没想到真的把这想法变成了现实，楼主真是神人也

祥子

老猫要常来逛逛啊,你的帖子都很具代表性啊

xchrimp

没有实用性，网友定制程序不会用到这些。学习LISP也不会学这没价值的附加资料