[原创] ！将vbscript移植到lisp！

cnks

难得上网，一上来就见到不错的资料

飞诗(fsxm)

虽说有的方面功能可能比lisp多一点点但事实上大多数都是用不到的啦!
我这个函数写出来很久了,但几乎都没用到过,
在CAD的lisp中用不到太高深的系统方面的知识的,
就如之前一高人发的win32api for lisp功能够强大吗?但为什么用的人不多
用来解决时常小小的CAD问题的,实际上就lisp就够了没必要用太多的混合编程,
会很多编程语言的人都不用lisp来编程了.
想想你都可以在lisp中用字符拼成VB语句说明你VB用的很好哦
你直接就用VBA来写程序不是更快更好?,为什么还要用lisp来拼写VB语句呢?
下面我的fsxm-vbs源程序代码,
秘诀就是:写一个会写vbs函数的lisp程序!
这是核心代码:
  (foreach x cmd
    (setq i (1+ i))
    (setq pastr (if x (strcat "Fsxm" (itoa i)) " "))
    (setq cmdstr0 (strcat cmdstr0 " , " "Fsxm" (itoa i)))
    (setq cmdstr1 (strcat cmdstr1 " , " pastr))
  )
完整代码如下:

3. (cond ((null *MSSC*)
4.        (setq *MSSC* (vlax-create-object "MSScriptControl.ScriptControl"))
5.        (vlax-put *MSSC* "Language" "VBS")
6.       )
7. )
8. (defun Fsxm-VBS-Eval (str)
9.   (vlax-invoke *MSSC* 'eval str)
10. )
11. (defun Fsxm-VBS-Exec (str)
12.   (vlax-invoke-method *MSSC* 'ExecuteStatement str)
13. )
14. (defun Fsxm-VBS-Run (Fun_lst)
15.   (vl-catch-all-apply 'vlax-invoke(vl-list* *mssc* "run" Fun_lst))
16. )
17. (defun Fsxm-VBS (VBSlst / cmd cmdstr0 cmdstr1 func i pastr return)
18.   (setq func (vl-princ-to-string (car VBSlst))
19. cmdstr0 ""
20. cmdstr1 ""
21. i 0
22. cmd (cdr VBSlst)
23.   )
24.   (foreach x cmd
25.     (setq i (1+ i))
26.     (setq pastr (if x (strcat "Fsxm" (itoa i)) " "))
27.     (setq cmdstr0 (strcat cmdstr0 " , " "Fsxm" (itoa i)))
28.     (setq cmdstr1 (strcat cmdstr1 " , " pastr))
29.   )
30.   (setq cmdstr0 (substr cmdstr0 4))
31.   (setq cmdstr1 (substr cmdstr1 4))
32.   (Fsxm-VBS-Exec
33.     (strcat
34.       "Function Fsxm_vbs(" cmdstr0  ")\nFsxm_vbs = Array ("
35.       func     "("   cmdstr1
36.       "))\nEnd Function"
37.      )
38.   )
39.   (setq return (vl-catch-all-apply
40.    'vlax-invoke
41.    (append (list *mssc* "run" "Fsxm_vbs") cmd)
42.         )
43.   )
44.   (if (listp return) (car return) return)
45. )

(cond ((null *MSSC*)        (setq *MSSC* (vlax-create-object "MSScriptControl.ScriptControl"))        (vlax-put *MSSC* "Language" "VBS")       ) ) (defun Fsxm-VBS-Eval (str)   (vlax-invoke *MSSC* 'eval str) ) (defun Fsxm-VBS-Exec (str)   (vlax-invoke-method *MSSC* 'ExecuteStatement str) ) (defun Fsxm-VBS-Run (Fun_lst)   (vl-catch-all-apply 'vlax-invoke(vl-list* *mssc* "run" Fun_lst)) ) (defun Fsxm-VBS (VBSlst / cmd cmdstr0 cmdstr1 func i pastr return)   (setq func (vl-princ-to-string (car VBSlst)) cmdstr0 "" cmdstr1 "" i 0 cmd (cdr VBSlst)   )   (foreach x cmd     (setq i (1+ i))     (setq pastr (if x (strcat "Fsxm" (itoa i)) " "))     (setq cmdstr0 (strcat cmdstr0 " , " "Fsxm" (itoa i)))     (setq cmdstr1 (strcat cmdstr1 " , " pastr))   )   (setq cmdstr0 (substr cmdstr0 4))   (setq cmdstr1 (substr cmdstr1 4))   (Fsxm-VBS-Exec     (strcat       "Function Fsxm_vbs(" cmdstr0  ")\nFsxm_vbs = Array ("       func     "("   cmdstr1       "))\nEnd Function"      )   )   (setq return (vl-catch-all-apply    'vlax-invoke    (append (list *mssc* "run" "Fsxm_vbs") cmd)         )   )   (if (listp return) (car return) return) )

zml84

看样子，可以打通alisp的任督二脉了。

yshf

相当不错的资料,的确让人大开眼界。既然fsxm大侠已经公布了秘诀，无痕版主是否舍得将你的源程序拿出来让大家共赏，对比和学习学习呢？

torcky

强悍！！编程越来越简单了，但是想成为高手却越来越难了！！！

oyxx1023

i fl u.l h.

无痕

fsxm 的 写一个会写vbs函数的lisp程序! 的想法很好.我进行了如下测试

(fsxm-vbs '(msgbox "测试"))
(fsxm-vbs '(msgbox "测试" & "ok")) -> 丢失"ok"
(fsxm-vbs '(msgbox (strcat "测试 " "&" " ok"))) -> #<%catch-all-apply-error%>
(fsxm-vbs '(msgbox (strcat "测试 " & " ok"))) -> #<%catch-all-apply-error%>
(fsxm-vbs '(msgbox ("测试 " & " ok"))) ->#<%catch-all-apply-error%>

也许我的方法不对.没有得出想要的结果.发现未能够很好支持 &,+等函数,vbs函数在表达式中未能嵌套.

于是自己对原来的xcal做了升级.借用了fsxm的将vbs函数写成lisp函数格式的

想法.并且作了功能上的增强.将函数方式进行到底！详细介绍如下:

(xvbs a) = 函数方式执行vbs语句(第二代)    by 梁雄啸.2007.8
函数：xvbs
格式：(xvbs 函数表达式)
参数：函数表达式，格式：表 或 字符串.
      vbs函数用'引导，如：(list 'msgbox "测试") 或 '(msgbox "测试").
      可多重嵌套.
      支持lisp变量.变量不用'引导.
      支持vbs的&,+等函数.
      字符串格式,如:
测试:
1. (xvbs '(msgbox ("测试时间 : " & vbcr & now )1))
2. 支持变量:
   (setq path (getvar "acadver"))
   (xvbs (list 'msgbox (list "测试" '& 'vbcr '& path) 3))
3. 支持在函数表达式中使用lisp语句:
   (xvbs(list 'msgbox (list "测试" '& 'vbcr '& (strcat "cad版本号 = " (getvar "acadver"))) 3))
4. 连续执行多个vbs语句,支持vbs中变量传递:
   (xvbs '(cs = "测试"))
   (xvbs '(msgbox (cs & "ok"))) ;; cs是在vbs中定义的变量.
5. 支持字符串表达式:
   (xvbs "msgbox(\"测试时间:\" & now)")

再对开始的实例进行测试:

(xvbs '(msgbox ("测试 " & " ok")))  ->返回正确.

下载请点链接:

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62199

龙龙仔

以下說明有例子嗎?

2.如果VBS內容過長,可分成幾段來移植,但是被調用的子函數必須寫在前面.
                  即把調用子函數的部分放到最後.有回車的地方要保留,如:
                  (setq STR \"
                  ****移植的語句****
                   \"
                  )

下列的註解你的程序會先處理掉嗎?

;; 正則表達式應用. ok
(setq str "            
function regexptest(patrn, strng)
dim regex, match, matches   ' 建立變量。
set regex = new regexp     ' 建立正則表達式。
regex.pattern = patrn     ' 設置模式。
regex.ignorecase = true     ' 設置是否區分字符大小寫。
regex.global = true     ' 設置全局可用性。
set matches = regex.execute(strng)  ' 執行搜索。
for each match in matches   ' 遍歷匹配集合。
retstr = retstr & \"match found at position \" & match.firstindex & \". match value is '\"
retstr = retstr & match.value & \"'.\" & vbcrlf
next
regexptest = retstr
end function
msgbox(regexptest(\"is.\", \"is1 is2 is3 is4\"))
")
(xxvbs str "")

无痕

回龙龙仔，你贴子里面那个就是实例。这只是建议的书写格式。

其实以下输入格式都是可以的：

1.
(setq str "            
a = \"测试\"
msgbox a
")
(xxvbs str "")
2.
(setq str "a = \"测试\"
           msgbox a")
(xxvbs str "")
3.
(setq str "a = \"测试\" \nmsgbox a")
(xxvbs str "")
4.
(xxvbs "a = \"测试\" \nmsgbox a" "")
5.
(xxvbs "a = \"测试\"
       msgbox a" "")

程序支持vbs语句加注解，我已经测试过，正常。

龙龙仔

我知道你的程序支持vbs语句加注解,但我重寫的程序不支持加注解,想不出為甚麼? 

也不支持wscript.CreateObject==>要改為CreateObject

我用下列

       (setq MSSC (vlax-create-object "MSScriptControl.ScriptControl"))

  OR     (setq MSSC (vlax-create-object "ScriptControl")) 都不支持加注解