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

无痕发表于 2007-8-8 01:47:00

本帖最后由作者于 2007-8-19 16:51:37 编辑

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

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

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 & \"\\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?."
|;

无痕发表于 2007-8-8 01:58:00

本帖最后由作者于 2007-8-15 21:08:27 编辑 最新v2.1版下载地址: 函数应用秒杀本地打印机列表<a href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62103">http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62103</a><div class="htmlcode" id="mc34362" style="BORDER-RIGHT: #ccc 1px solid; BORDER-TOP: #ccc 1px solid; PADDING-LEFT: 5px; BORDER-LEFT: #ccc 1px solid; BORDER-BOTTOM: #ccc 1px solid;">(<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> 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 &  \")\"    ") (<a href="http://www.mjtd.com/object/autolisp/read.htm" target="_black">read</a>   (xxvbs str "ret")) -> ("hp deskjet 695c series"   "Canon BJC-6500 (BJRSTR)")    </div><div class="codebar" style="TEXT-ALIGN: right;"><a href="javascript:copycode('mc19489')">[复制代码到剪贴板]</a></div><div class="htmlcode" id="mc19489" style="BORDER-RIGHT: #ccc 1px solid; BORDER-TOP: #ccc 1px solid; PADDING-LEFT: 5px; BORDER-LEFT: #ccc 1px solid; BORDER-BOTTOM: #ccc 1px solid;">(<a href="http://www.mjtd.com/object/autolisp/setq.htm" target="_black">setq</a> 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 &  \")\"           ") (<a href="http://www.mjtd.com/object/autolisp/read.htm" target="_black">read</a>   (xxvbs str "ret")) -> ("hp deskjet 695c series"   "Canon BJC-6500 (BJRSTR)")    </div>

无痕发表于 2007-8-8 02:54:00

;;取得本机IP(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 取得本机计算机名(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 检索本地共享(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文件)(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 "")

无痕发表于 2007-8-8 10:17:00

;; 判断是否是网址.....(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
(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!(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 发表于 2007-8-8 10:56:00

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

killer9806 发表于 2007-8-8 12:33:00

技术的革新，太强了

飞诗(fsxm) 发表于 2007-8-8 21:00:00

我以前在QQ群中发布过,也可以到 <a href="http://fsxm.ys168.com/">http://fsxm.ys168.com/</a>中下载 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))不用多说了吧!就是这么简单!

无痕发表于 2007-8-8 21:24:00

本帖最后由作者于 2007-8-9 2:04:26 编辑 欢迎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 & \"<a href="file://\\root\\cimv2\">\\root\\cimv2\</a>") 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> \"&\"<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")

无痕发表于 2007-8-8 22:05:00

本帖最后由作者于 2007-8-8 22:13:30 编辑 欢迎fsxm一起来探讨。我在昨天发的vbs进行字符串表达式求值 <a href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62105">http://bbs.mjtd.com/forum.php?mod=viewthread&tid=62105</a>也是调用vbs函数的。fsxm老弟更进一步，做成函数调用格式了。至于哪种用起来方便，就由大家去选择了。不过移植和调用vbs还是不一样。诚然，vbs其实都可以通过调用不同的vbs函数改写。之所以有移植的想法，是懒。因为看到网上好多的vbs程序，太多了，一想到要改写，就心烦，重复劳动太多，而且还有比较重要的一点是，光调用vbs函数还不够，还要能使用vbs的结构语句，比如 for语句if语句，才能发挥其威力。移植的话就算不太懂编程的，也可以自己依葫芦画瓢diy一个比较强的函数，只要从网上找一个这样的vbs源码，稍微改装就可以（千万别用来黑明经啊:P）。比如2～4楼的实例，如果通过调用函数的方式改编，不知道要多久，而这些实例，我都是从网上搜索拷贝粘贴来的，3分钟就出一个。我移植的想法就是这样，一切因为懒，而移植是一种方便的（傻瓜的，某种程度上也可以说是高效的）方式：）

mccad 发表于 2007-8-9 18:19:00

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

页: [1] 2 3 4 5 6 7 8

明经CAD社区's Archiver

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