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

无痕

                                         将vbscript移植到lisp
更新到v2.2版本:完善数组返回值.完善对wscript. 的判断 . ret支持表,字符,符号格式.
姊妹版: 将jscript移植到lisp :  http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62386


前段时间研究了下正则表达式，对vbs有了更进一步的理解。于是一鼓作气，搞了个将vbs程序移植到lisp的函数。
大家知道，网络上vbscript的程序是很多的，功能也很强，从获取系统信息，到读写网络，编辑网页，甚至操控windows系统底层（因此成了木马的载体）
而这些，现在相当部分（因为没有经过全面严格测试，所以只能说相当部分）的程序代码，可以在cad中直接拷贝使用。只需要按如下说明进行极少量的转换即可。

2. ;| (xxvbs str)=移植vbs程序的函数 ---------------by 梁雄啸.2007.7
3. 函数: xxvbs
4. 格式: (xxvbs str)
5. 参数: str = vbs语句.
6.       说明: 1.可将多行vbs程序拷贝移植,注意: " 应用 "替代, \ 号应用 \\ 替代.
7.               2.如果vbs内容过长,可分成几段来移植,但是被调用的子函数必须写在前面.即把调用子函数的部分放到最后.有回车的地方要保留,如:
8.             (setq str "
9.               ****移植的语句****
10.               "
11.               )
12.       ret = vbs语句中返回值变量.支持表,字符,符号格式.
13.             如: '(a "b") , "b" , 'a 返回: 执行vbs,返回vbs返回值.
14. 版本: v2.2 数组返回值函数除错,可很好地支持多维数组.
15.      v2 完善数组返回值.完善对wscript. 的判断 . ret支持表,字符,符号格式.
16.       v1 完成基本移植功能.支持多行
17. 实例:
18.   (xxvbs "a=10+3*5 \n b=a-2" "b") ;;返回: 23
19. |;

;| (xxvbs str)=移植vbs程序的函数 ---------------by 梁雄啸.2007.7 函数: xxvbs 格式: (xxvbs str) 参数: str = vbs语句.       说明: 1.可将多行vbs程序拷贝移植,注意: " 应用 "替代, \ 号应用 \\ 替代.               2.如果vbs内容过长,可分成几段来移植,但是被调用的子函数必须写在前面.即把调用子函数的部分放到最后.有回车的地方要保留,如:             (setq str "               ****移植的语句****               "               )       ret = vbs语句中返回值变量.支持表,字符,符号格式.             如: '(a "b") , "b" , 'a 返回: 执行vbs,返回vbs返回值. 版本: v2.2 数组返回值函数除错,可很好地支持多维数组.      v2 完善数组返回值.完善对wscript. 的判断 . ret支持表,字符,符号格式.       v1 完成基本移植功能.支持多行 实例:   (xxvbs "a=10+3*5 \n b=a-2" "b") ;;返回: 23 |;

函数下载
http://dreamskylxx.ys168.com/


v2.2版本实例:
补充实例:
1. (版本v2)
(setq str1 "Dim A \n A = Array(10,20,30,\"test\") \n B = \"测试1\"")
(setq str2 "Dim A : B = \"测试2\" : A = Array(10,20,30,B) : ")
(xxvbs str1 'a)  ;;返回: (10 20 30 "test")
(xxvbs str2 "a") ;;返回: (10 20 30 "测试2")  
(xxvbs str1 '(b "A")) ;;返回: ("测试1" (10 20 30 "test"))
(xxvbs str2 '(a ("b" a)))  ;; 返回: ((10 20 30 "测试2") ("测试2" (10 20 30 "测试2")))
2. (版本v2)
(setq str "Dim a(9) : for i = 0 TO 9 : a(i) = i : NEXT")
(xxvbs str "a")  ;; -> (0 1 2 3 4 5 6 7 8 9)
3. (版本v2)
(setq str "dim a : b = array(\"a\",\"B\") : a = array(array(1,2),b)" ret "a")
(xxvbs str ret) ;;返回: ((1 2) ("a" "B"))
(xxvbs str '(a (b "a(0)"))) ;;返回: (((1 2) ("a" "B")) (("a" "B") (1 2)))



[/url]
4.(版本v2.2)
(setq str "
Function   GetValue()   
          Dim   arrX(3 , 3 , 2)
          Dim   i,j,k   
          For   i = 0 To 3   
               For j = 0 To 3
                  For k = 0 To 2
                     arrX (i , j , k) = i * j + k
                  Next
               Next
          Next   
          GetValue = arrX   
  End   Function"
)
(xxvbs str "getvalue")
;;返回: (((0 1 2) (0 1 2) (0 1 2) (0 1 2)) ((0 1 2) (1 2 3) (2 3 4) (3 4 5))
((0 1 2) (2 3 4) (4 5 6) (6 7 8)) ((0 1 2) (3 4 5) (6 7 8) (9 10 11)))

;| v1版本:
测试1:
;; 本例建立一个快捷方式.
(setq str "
         set WshShell = wscript.CreateObject(\"WScript.Shell\")
         strDesktop = WshShell.SpecialFolders(\"Desktop\")
         set oShellLink = WshShell.CreateShortcut (strDesktop & \"[url=file://Shortcut/]\\Shortcut Script.lnk\")
         oShellLink.TargetPath = wscript.ScriptFullName
         oShellLink.WindowStyle = 1
         oShellLink.Hotkey = \"CTRL+SHIFT+F\" \n
         oShellLink.IconLocation = \"notepad.exe, 0\"
         oShellLink.Description = \"Shortcut Script\"
         oShellLink.WorkingDirectory = strDesktop
         oShellLink.Save "
       )
(xxvbs str "") -> 成功建立快捷方式!


测试2:
;;本例测试条件语句,循环语句,并返回 a 的值.
(setq str "
      dim a
      a = 1
      for i=1 to 5
      a=a*i-a+1
      next
      if a < 100 then msgbox \"a=\" & a & \"<100\" else msgbox \"a=\" & a & \">100\"
      "
)
(xxvbs str "a")

;; 测试3:
谁说lisp调用vbs不能有条件语句的
(setq str "
      dim A,B,C
      ANS = \"谁说lisp调用vbs不能有条件语句的\"
      a = 1
      for i=1 to 5
      a=a*i-a+1
      next
      if a > 100 then
      A = A + 1 : B = A^A : C = A + B
      ELSE
      A = A  : B = A : C = A + B
      END IF
      msgbox \"a=\" & a & \" b=\" & b & \" c=\" & c & vbcr & ans
      "
)
(xxvbs str "C")

;; 将两个连续字符替换为一个．
(setq str "
Dim ss, re, rv
ss = inputbox(\"将两个连续字符替换为一个，输入测试字符:\")
Set re = New RegExp
re.Pattern = \"(.+)\\1\"
re.Global = True
re.IgnoreCase = True
re.MultiLine = True
rv = re.Replace(ss,\"$1\")
")
(xxvbs str "rv")
;; 将两个连续单词替换为一个(单词间以空格分隔)
(setq str "
Dim ss, re, rv
ss = \"Is is the cost of of gasoline going up up?.\"
Set re = New RegExp
re.Pattern = \"\\b(.+) \\1\\b\"
re.Global = True
re.IgnoreCase = True
re.MultiLine = True
rv = re.Replace(ss,\"$1\")
")
(xxvbs str "rv") -> "Is the cost of gasoline going up?."
|;

无痕

最新v2.1版下载地址:

 

函数应用

秒杀本地打印机列表

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

(setq str "
Set WshNetwork = WScript.CreateObject(\"WScript.Network\")
Set oPrinters = WshNetwork.EnumPrinterConnections
ret = \"\"
For i = 0 to oPrinters.Count - 1 Step 2
ret = ret & chr(34) & oPrinters.Item(i+1) & chr(34)
Next
ret =  \"(\" & ret &  \")\"
  
")
(read
  (xxvbs str "ret")) -> ("hp deskjet 695c series"
  "Canon BJC-6500 (BJRSTR)")
  

[复制代码到剪贴板]

(setq str "
strComputer = \".\"
ret = \"\"
Set objWMIService = GetObject(\"winmgmts:\" & \"{impersonationLevel=impersonate}!\\\\\" & strComputer & \"\\root\\cimv2\")
Set colInstalledPrinters =  objWMIService.ExecQuery (\"Select * from Win32_Printer\")
For Each objPrinter in colInstalledPrinters
     ret = ret & chr(34) & objPrinter.Name & chr(34)
  
Next
ret =  \"(\" & ret &  \")\"
  
       ")
(read
  (xxvbs str "ret")) -> ("hp deskjet 695c series"
  "Canon BJC-6500 (BJRSTR)")
  

无痕

;;取得本机IP

2. (setq str "
3. strComputer = "."  
4. Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2")
5. Set IPConfigSet = objWMIService.ExecQuery("Select IPAddress from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")
6. For Each IPConfig in IPConfigSet  
7. If Not IsNull(IPConfig.IPAddress) Then  
8. For Each strAddress in IPConfig.IPAddress  
9. msgbox strAddress  
10. Next  
11. End If  
12. Next
13. ")
14. (xxvbs str "")

(setq str " strComputer = "."   Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2") Set IPConfigSet = objWMIService.ExecQuery("Select IPAddress from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE") For Each IPConfig in IPConfigSet   If Not IsNull(IPConfig.IPAddress) Then   For Each strAddress in IPConfig.IPAddress   msgbox strAddress   Next   End If   Next ") (xxvbs str "")

;2 取得本机计算机名

2. (setq str "
3.       strComputer = "."  
4. Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2")  
5. Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")  
6. For Each objComputer in colComputers  
7. msgbox objComputer.Name
8. Next
9. ")
10. (xxvbs str "")

(setq str "       strComputer = "."   Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2")   Set colComputers = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")   For Each objComputer in colComputers   msgbox objComputer.Name Next ") (xxvbs str "")

;12 检索本地共享

2. (setq str "
3.       ret = ""
4.       strComputer = "."  
5. Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2")  
6. Set colShares = objWMIService.ExecQuery("Select * from Win32_Share")  
7. For each objShare in colShares  
8. ret = ret & "Name: " & objShare.Name & "  Path: " & objShare.Path & "  Type: " & objShare.Type & vbcrlf
9. Next
10. msgbox ret
11. ")
12. (xxvbs str "ret")

(setq str "       ret = ""       strComputer = "."   Set objWMIService = GetObject("winmgmts:\\\\" & strComputer & "\\root\\cimv2")   Set colShares = objWMIService.ExecQuery("Select * from Win32_Share")   For each objShare in colShares   ret = ret & "Name: " & objShare.Name & "  Path: " & objShare.Path & "  Type: " & objShare.Type & vbcrlf Next msgbox ret ") (xxvbs str "ret")

;13 脚本检索一个文件夹下.txt文件 (本例为c:\下所有txt文件)

2. (setq str "
3. Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")
4. Set colFiles = objWMIService.ExecQuery("SELECT * FROM CIM_DataFile WHERE Path = '\\\\' AND Drive = 'C:' AND Extension = 'txt'")
5. msgbox "Number of .txt files found: " & colFiles.Count  
6. for each aa in colFiles
7. NL=NL & vbcrlf & aa.name
8. next
9. msgbox NL
10. ")
11. (xxvbs str "")

(setq str " Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2") Set colFiles = objWMIService.ExecQuery("SELECT * FROM CIM_DataFile WHERE Path = '\\\\' AND Drive = 'C:' AND Extension = 'txt'") msgbox "Number of .txt files found: " & colFiles.Count   for each aa in colFiles NL=NL & vbcrlf & aa.name next msgbox NL ") (xxvbs str "")

无痕

;; 判断是否是网址.....

2. (setq str1 "
3.               function isemail(strng)
4.               isemail = false
5.               dim regex, match
6.               set regex = new regexp
7.               regex.Pattern = "(http://)?([\\w-]+\\.)+[\\w-]+(/[\\w- ./?%&=]*)?"
8.               regex.ignorecase = true
9.               set match = regex.execute(strng)
10.               if match.count then isemail = true
11.               end function
12.               msgbox isemail(inputbox("输入网址:"))
13.               "
14.       )
15.       (xxvbs str1 "") ;; 测试输入: http://www.mjtd.com

(setq str1 "               function isemail(strng)               isemail = false               dim regex, match               set regex = new regexp               regex.Pattern = "(http://)?([\\w-]+\\.)+[\\w-]+(/[\\w- ./?%&=]*)?"               regex.ignorecase = true               set match = regex.execute(strng)               if match.count then isemail = true               end function               msgbox isemail(inputbox("输入网址:"))               "       )       (xxvbs str1 "") ;; 测试输入: http://www.mjtd.com

;; 正则表达式应用. ok

2. (setq str "            
3. function regexptest(patrn, strng)
4. dim regex, match, matches   ' 建立变量。
5. set regex = new regexp     ' 建立正则表达式。
6. regex.pattern = patrn     ' 设置模式。
7. regex.ignorecase = true     ' 设置是否区分字符大小写。
8. regex.global = true     ' 设置全局可用性。
9. set matches = regex.execute(strng)  ' 执行搜索。
10. for each match in matches   ' 遍历匹配集合。
11. retstr = retstr & "match found at position " & match.firstindex & ". match value is '"
12. retstr = retstr & match.value & "'." & vbcrlf
13. next
14. regexptest = retstr
15. end function
16. msgbox(regexptest("is.", "is1 is2 is3 is4"))
17. ")
18. (xxvbs str "")

(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 "")

;;通过WMI对象获得系统中运行的的进程  ok!

2. (setq str "
3. Function Enum1()
4.     Set WMI = GetObject("WinMgmts:")
5.     Set objs = WMI.InstancesOf("Win32_Process")
6.     For Each obj In objs
7.         Enum1 = Enum1 & obj.Description & Chr(13) & Chr(10)
8.     Next
9. End Function
10. msgbox (enum1)
11. ")
12. (xxvbs str "")

(setq str " Function Enum1()     Set WMI = GetObject("WinMgmts:")     Set objs = WMI.InstancesOf("Win32_Process")     For Each obj In objs         Enum1 = Enum1 & obj.Description & Chr(13) & Chr(10)     Next End Function msgbox (enum1) ") (xxvbs str "")

zml84

让lisp与vbs联姻，实在强大！

killer9806

技术的革新，太强了

飞诗(fsxm)

我以前在QQ群中发布过,也可以

到 http://fsxm.ys168.com/中 下载 fsxm-vbs.fas 1K

可以以标准的lisp函数格式(不是字符串)调用绝大多数VBS函数!

比如:

(fsxm-vbs '(msgbox "测试"))

(fsxm-vbs '(abs -10))

(fsxm-vbs '(split "123 456 789"))

(fsxm-vbs '(GetObject "WinMgmts:"))

(fsxm-vbs '(rnd))

变量请用list如:

(fsxm-vbs (list 'cstr pi))

不用多说了吧!就是这么简单!

无痕

欢迎fsxm一起探讨。先补几个实例

;检索计算机上安装的光驱:
(setq str "
ret = \"\"
strComputer = \".\"
Set objSWbemLocator = CreateObject(\"WbemScripting.SWbemLocator\")
Set objSWbemServices = objSWbemLocator.ConnectServer
Set colItems = objSWbemServices.ExecQuery(\"Select * from Win32_CDROMDrive\")
For Each objItem in colItems
   ret = ret &  \"光盘驱动器的类型: \" & objItem.Caption & vblf
   ret = ret &  \"盘符是: \" & objItem.Id
Next
msgbox ret")
(xxvbs str "ret")
;-> "光盘驱动器的类型: SAMSUNG CDRW/DVD SM-332F\n盘符是: K:光盘驱动器的类型: AXV CD/DVD-ROM SCSI CdRom Device\n盘符是: L:"

;; 获得CPU的序列号。
(setq str "
Set objSWbemObject = GetObject(\"winmgmts:Win32_Processor.DeviceID='cpu0'\")
ret = objSWbemObject.ProcessorId
msgbox \"首枚CPU序列号：\" & ret
")
(xxvbs str "ret")

;;使用 WMI 和 VBScript 检索操作系统信息
(setq str "
strComputer = \".\"
Set objWMIService = GetObject(\"winmgmts:\\\\\" & strComputer)
Set colOperatingSystems = objWMIService.InstancesOf(\"Win32_OperatingSystem\")
For Each objOperatingSystem In colOperatingSystems
msgbox \"Name:  \" & objOperatingSystem.Name   & vbCrLf & \"Caption:  \" & objOperatingSystem.Caption & vbCrLf & \"CurrentTimeZone: \" & objOperatingSystem.CurrentTimeZone & vbCrLf & \"LastBootUpTime:  \" & objOperatingSystem.LastBootUpTime  & vbCrLf &  \"LocalDateTime:   \" & objOperatingSystem.LocalDateTime   & vbCrLf &  \"Locale:   \" & objOperatingSystem.Locale & vbCrLf &  \"Manufacturer:    \" & objOperatingSystem.Manufacturer & vbCrLf &  \"OSType:   \" & objOperatingSystem. OSType  & vbCrLf &  \"Version:     \" & objOperatingSystem.Version & vbCrLf & \"Service Pack:    \" & objOperatingSystem.ServicePackMajorVersion  &  \".\" & objOperatingSystem.ServicePackMinorVersion & vbCrLf &  \"Windows Directory: \" & objOperatingSystem.WindowsDirectory
Next
")
(xxvbs str "")

;;使用 WMI 和 VBScript 检索在 root\cimv2 命名空间中注册的 Win32 提供程序
(setq str "strComputer = \".\"
ret = \"\"
Set objWMIService = GetObject(\"winmgmts:\\\\\" & strComputer & \"\\root\\cimv2\")
Set colWin32Providers = objWMIService.InstancesOf(\"__Win32Provider\")
For Each objWin32Provider In colWin32Providers
ret = ret & objWin32Provider.Name & vblf
Next
msgbox ret")
(xxvbs str "ret")

;;很多GUI工具(比如流光)启动时，有一个logo页，显示版权等信息。我们用ie对象也可以模拟一个出来
(defun c:logo()
(setq str "
set wscript = createobject(\"wscript.shell\")
set ie = wscript.createobject(\"internetexplorer.application\")
ie.fullscreen = 1
ie.width = 300
ie.height = 150
ie.navigate \"about\"&\":blank\"
ie.left = fix((ie.document.parentwindow.screen.availwidth-ie.width)/2)
ie.top = fix((ie.document.parentwindow.screen.availheight-ie.height)/2)
str = \"<body bgcolor  = skyblue scroll = no><br><br>\"&\"<h2 align = center>这是一个Logo</h2></body>\"
str = & str &
ie.document.write
ie.visible = 1
wscript.sleep 5000
ie.quit ")
(xxvbs str "ret"))

;;在ie调用系统颜色选择对话
(setq str
"set ie = createobject(\"internetexplorer.application\")
set wscript = createobject(\"wscript.shell\")
ie.navigate \"about:blank\"
do until ie.readystate = 4 : wscript.sleep 25 : loop
set doc = ie.document
set body = doc.body
set win = doc.parentwindow
body.innerhtml = \"<OBJECT id=dlg CLASSID='clsid:3050f819-98b5-11cf-bb82-00aa00bdce0b'></OBJECT>\"
body.innertext = doc.getElementById(\"dlg\").choosecolordlg
win.clipboarddata.setdata \"text\", body.innertext
ie.quit ")
(xxvbs str "ret")

无痕

欢迎fsxm一起来探讨。我在昨天发的

vbs进行字符串表达式求值 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62105

也是调用vbs函数的。fsxm老弟更进一步，做成函数调用格式了。至于哪种用起来方便，就由大家去选择了。

不过移植和调用vbs还是不一样。诚然，vbs其实都可以通过调用不同的vbs函数改写。之所以有移植的想法，是懒。因为看到网上好多的vbs程序，太多了，一想到要改写，就心烦，重复劳动太多，而且还有比较重要的一点是，光调用vbs函数还不够，还要能使用vbs的结构语句，比如 for语句if语句，才能发挥其威力。移植的话就算不太懂编程的，也可以自己依葫芦画瓢diy一个比较强的函数，只要从网上找一个这样的vbs源码，稍微改装就可以（千万别用来黑明经啊:P）。比如2～4楼的实例，如果通过调用函数的方式改编，不知道要多久，而这些实例，我都是从网上搜索拷贝粘贴来的，3分钟就出一个。

我移植的想法就是这样，一切因为懒，而移植是一种方便的（傻瓜的，某种程度上也可以说是高效的）方式：）

mccad

靠，这么强的功能，以后大家都不用写程序了，网上粘粘就可以了。