VBS常用代码合集.doc

VBS常用代码合集(个人整理)从系统开始菜单中删除此链接: 复制代码 代码如下:Windows Registry Editor Version 5.00 HKEY_CLASSES_ROOT/CLSID/2559a1f6-21d7-11d4-bdaf-00c04f60b9f0 =- InfoTip=- HKEY_CLASSES_ROOT/CLSID/2559a1f6-21d7-11d4-bdaf-00c04f60b9f0/DefaultIcon =- HKEY_CLASSES_ROOT/CLSID/2559a1f6-21d7-11d4-bdaf-00c04f60b9f0/Instance/InitPropertyBag Command=- Param1=- VBS脚本实现整理磁盘碎片功能 Set WshShell = WScript.CreateObject(WScript.Shell) Dim fso, d, dc Set fso = CreateObject(Scripting.FileSystemObject) Set dc = fso.Drives For Each d in dc If d.DriveType = 2 Then Return = WshShell.Run(defrag & d & -f, 1, TRUE) End If Next Set WshShell = Nothing 计划任务定时调用VBS脚本 复制代码 代码如下:Option Explicit On Error Resume Next 生成列表的文件类型 Const sListFileType = wmv,rm,wma 文件所在的相对路径 Const sShowPath=. 排序类型的常量定义 Const iOrderFieldFileName = 0 Const iOrderFieldFileExt = 1 Const iOrderFieldFileSize = 2 Const iOrderFieldFileType = 3 Const iOrderFieldFileDate = 4 排序顺逆的常量定义 const iOrderAsc = 0 const iOrderDesc = 1 生成列表的文件数量 const iShowCount = 20 显示的日期格式函数 Function Cndate2(date1,intDateStyle) dim strdate,dDate1 strdate=cstr(date1) If Isdate(strdate) Then If Left(cstr(strdate),1)=0 Then dDate1=Cdate(20+cstr(strdate) else dDate1=Cdate(strdate) End If Else dDate1=Now() End If Select case intDateStyle Case 1: Cndate2 = Cstr(Year(dDate1)+-+Cstr(Month(dDate1)+-+Cstr(Day(dDate1) Case 2: Cndate2 = Cstr(Month(dDate1)+-+Cstr(Day(dDate1) Case 3: Cndate2 = Cstr(Month(dDate1)+月+Cstr(Day(dDate1)+日 Case 4: Cndate2 = Cstr(year(dDate1)+年+ Cstr(Month(dDate1)+月+Cstr(Day(dDate1)+日 End Select End Function Function ListFile(strFiletype,intCompare,intOrder,intShowCount) Dim sListFile Dim fso, f, f1, fc, s,ftype,fcount,i,j,k Dim t1,t2,t3,t4,t5 Dim iMonth,iDay sListFile = Set fso = CreateObject(Scripting.FileSystemObject) Set f = fso.GetFolder(sShowPath) Set fc = f.Files fcount = fc.count redim arrFiles(fcount,5) redim arrFiles2(fcount,5) i=0 排序 For Each f1 in fc ftype = right(,len()-instrrev(,.) arrFiles(i,0) = arrFiles(i,1) = ftype arrFiles(i,2) = f1.size arrFiles(i,3) = f1.type arrFiles(i,4) = f1.DateLastModified i=i+1 Next For i=0 to fcount-1 for j=i+1 to fcount-1 select Case intCompare Case iOrderFieldFileName,iOrderFieldFileExt,iOrderFieldFileType: If arrFiles(i,intCompare)arrFiles(j,intCompare) then t1 = arrFiles(i,0) t2 = arrFiles(i,1) t3 = arrFiles(i,2) t4 = arrFiles(i,3) t5 = arrFiles(i,4) arrFiles(i,0) = arrFiles(j,0) arrFiles(i,1) = arrFiles(j,1) arrFiles(i,2) = arrFiles(j,2) arrFiles(i,3) = arrFiles(j,3) arrFiles(i,4) = arrFiles(j,4) arrFiles(j,0) = t1 arrFiles(j,1) = t2 arrFiles(j,2) = t3 arrFiles(j,3) = t4 arrFiles(j,4) = t5 end if Case iOrderFieldFileSize: If cdbl(arrFiles(i,intCompare)cdbl(arrFiles(j,intCompare) then t1 = arrFiles(i,0) t2 = arrFiles(i,1) t3 = arrFiles(i,2) t4 = arrFiles(i,3) t5 = arrFiles(i,4) arrFiles(i,0) = arrFiles(j,0) arrFiles(i,1) = arrFiles(j,1) arrFiles(i,2) = arrFiles(j,2) arrFiles(i,3) = arrFiles(j,3) arrFiles(i,4) = arrFiles(j,4) arrFiles(j,0) = t1 arrFiles(j,1) = t2 arrFiles(j,2) = t3 arrFiles(j,3) = t4 arrFiles(j,4) = t5 end if Case iOrderFieldFileDate: If Cdate(arrFiles(i,intCompare)Cdate(arrFiles(j,intCompare) then t1 = arrFiles(i,0) t2 = arrFiles(i,1) t3 = arrFiles(i,2) t4 = arrFiles(i,3) t5 = arrFiles(i,4) arrFiles(i,0) = arrFiles(j,0) arrFiles(i,1) = arrFiles(j,1) arrFiles(i,2) = arrFiles(j,2) arrFiles(i,3) = arrFiles(j,3) arrFiles(i,4) = arrFiles(j,4) arrFiles(j,0) = t1 arrFiles(j,1) = t2 arrFiles(j,2) = t3 arrFiles(j,3) = t4 arrFiles(j,4) = t5 end if End Select next next 生成列表 sListFile = sListFile + () sListFile = sListFile + () sListFile = sListFile + (名称) sListFile = sListFile + () sListFile = sListFile + (媒体) sListFile = sListFile + () sListFile = sListFile + (大小) sListFile = sListFile + () sListFile = sListFile + (类型) sListFile = sListFile + () sListFile = sListFile + (更新时间) sListFile = sListFile + () dim iLoopStart,iLoofEnd,iLoopStep If intOrder = 0 then iLoopStart = 0 iLoofEnd = fcount-1 iLoopStep = 1 Else iLoopStart = fcount-1 iLoofEnd = 0 iLoopStep = -1 End if dim iCount,sTDStyleClass iCount = 1 For j=iLoopStart to iLoofEnd Step iLoopStep If instr(strFiletype,arrFiles(j,1)0 and iCount=intShowCount then sTDStyleClass = PageListTd+Cstr(iCount mod 2)+1) sListFile = sListFile + () sListFile = sListFile + ( & arrFiles(j,0) &) If datediff(h,arrFiles(j,4),now)=24 then sListFile = sListFile + end if sListFile = sListFile + sListFile = sListFile + () 根据文件名规则,生成中文提示 select case left(arrFiles(j,0),3) case sc2: sListFile = sListFile + 四川卫视 case sd2: sListFile = sListFile + 山东卫视 case gd2: sListFile = sListFile + 广东卫视 case gx2: sListFile = sListFile + 广西卫视 end select 日期显示 If isnumeric(left(right(arrFiles(j,0),8),2) then iMonth = cint(left(right(arrFiles(j,0),8),2) iDay = cint(left(right(arrFiles(j,0),6),2) sListFile = sListFile + cstr(iMonth)+月 + cstr(iDay)+日 sListFile = sListFile + () Else response.write arrFiles(j,0) end if If arrFiles(j,2)1024*1024 then sListFile = sListFile + cstr(round(arrFiles(j,2)/1024/1024) sListFile = sListFile + (MB) else sListFile = sListFile + cstr(round(arrFiles(j,2)/1024) sListFile = sListFile + (KB) end if sListFile = sListFile + ( ) sListFile = sListFile + () sListFile = sListFile + cstr(arrFiles(j,3) sListFile = sListFile + () sListFile = sListFile + () sListFile = sListFile + (Cndate2(arrFiles(j,4),4) sListFile = sListFile + () sListFile = sListFile + () iCount = iCount+1 end if next sListFile = sListFile + ListFile = sListFile End Function 生成调用文件的过程 Sub ShowFileListContent() Dim tUpdatetime,sUpdateContent Dim fso,f,f_js,f_js_write Set fso = CreateObject(Scripting.FileSystemObject) Set f = fso.GetFolder(sShowPath) Set f_js = fso.GetFile(list.js) 比较调用文件与文件夹的最后修改时间 If f.DateLastModifiedf_js.DateLastModified then sUpdateContent = ListFile(sListFileType,iOrderFieldFileDate,iOrderDesc,iShowCount) Set f_js_write = fso.CreateTextFile(list.js, True) JS调用就加上下面这对document.write f_js_write.Write (document.write() f_js_write.Write (sUpdateContent) f_js_write.Write () f_js_write.Close End If End Sub Call ShowFileListContent() 可以代替网通宽带登陆器的一段vbs脚本 Dim WshShell, iexplorePath, iexploreselect iexplorePath=c:/Progra1/Intern1/iexplore.exe Set WshShell=WScript.CreateObject(WScript.Shell) WshShell.Run iexplorePath WScript.Sleep 2000 WshShell.AppActivate 用户上网登陆 WshShell.SendKeys 自己的账号TAB WshShell.SendKeys 自己的密码 WScript.Sleep 2000 WshShell.SendKeys ENTER 利用VBS脚本创建快捷方式 我们以QQ Aqing增强包参数配置器为例子,讲述如何利用VBS脚本创建快捷方式.代码如下: 代码: set WshShell = Wscript.CreateObject(Wscript.Shell) strDesktop = WshShell.SpecialFolders(Desktop) set oShellLink = WshShell.CreateShortcut(strDesktop & /QQ Aqing增强包参数配置器.lnk) 创建一个快捷方式对象,其在桌面上显示的名字为QQ Aqing增强包参数配置器 oShellLink.TargetPath = C:/Program Files/Tencent/QQ/Aqing.exe 设置快捷方式的执行路径 oShellLink.WindowStyle = 1 oShellLink.Hotkey = Ctrl+Alt+e 设置快捷方式的快捷键 oShellLink.IconLocation = E:/Picture/Aqing.ico 设置快捷方式的图标路径 oShellLink.Description = QQ Aqing增强包参数配置器 设置快捷方式的描述 oShellLink.WorkingDirectory = strDesktop oShellLink.Save 将上述代码保存为CreateShortcut.vbs(不含引号).双击CreateShortcut.vbs,就会将QQ Aqing增强包参数配置器的快捷方式建立到桌面上. 用这种方法建立的快捷方式的最大优点是:快捷方式的图标可以根据自己的喜好进行更改 用VBS脚本发送email! code Set objEmail = CreateObject(CDO.Message) objEmail.From = null_ objEmail.To = null_ objEmail.Subject = 这封邮件是由VBS脚本发送 objEmail.Textbody = 如果你收到这封邮件，就表示测试成功！ objEmail.Send 利用vbs脚本编写Windows XP/2003序列号更改器 复制代码 代码如下:ON ERROR RESUME NEXT Dim VOL_PROD_KEY if Wscript.arguments.count1 then VOL_PROD_KEY =InputBox(使用说明(OEM版无效)：&vbCr&vbCr& 本脚本程序将修改当前 Windows 的序列号。请先使用算号器算出匹配当前 Windows 的序列号，复制并粘贴到下面空格中。&vbCr&vbCr&输入序列号(默认为 XP VLK)：,Windows XP/2003 序列号更换工具,11111-11111-11111-11111-11111) if VOL_PROD_KEY= then Wscript.quit end if else VOL_PROD_KEY = Wscript.arguments.Item(0) end if VOL_PROD_KEY = Replace(VOL_PROD_KEY,-,) remove hyphens if any for each Obj in GetObject(winmgmts:impersonationLevel=impersonate).InstancesOf (win32_WindowsProductActivation) result = Obj.SetProductKey (VOL_PROD_KEY) if err = 0 then Wscript.echo 您的 Windows CD-KEY 修改成功。请检查系统属性。 end if if err 0 then Wscript.echo 修改失败！请检查输入的 CD-KEY 是否与当前 Windows 版本相匹配。 Err.Clear end if Next 将上面的代码复制到文本里面,然后另存为.vbs文件,然后直接运行这个文件就可以了。 可升级Key: MRX3F-47B9T-2487J-KWKMF-RPWBY QC986-27D34-6M3TY-JJXP9-TBGMD CM3HY-26VYW-6JRYC-X66GX-JVY2D DP7CM-PD6MC-6BKXT-M8JJ6-RPXGJ F4297-RCWJP-P482C-YY23Y-XH8W3 HH7VV-6P3G9-82TWK-QKJJ3-MXR96 HCQ9D-TVCWX-X9QRG-J4B2Y-GR2TT 一段对比删除文件的VBS脚本!（用游戏更新的时候可以用到哦，希望大家灵活应用）dim sdir,ddir 远程目录 sdir=//vbs/zz/ 本地目录 ddir=c:/c function comparefile(sdir,ddir) dim Fso,dFol,dfs,sf1,f1 set Fso=CreateObject(Scripting.FileSystemObject) if not(Fso.folderexists(sdir) then msgbox chr(34) &sdir &chr(34) &文件夹不存在，请确认！,64 exit function end if if not(Fso.folderexists(ddir) then msgbox chr(34) &ddir &文件夹不存在，请确认！,64 exit function end if if right(sdir,1)/ then sdir=sdir &/ set dFol=fso.getfolder(ddir) set dfs=dfol.files for each f1 in dfs if fso.fileexists(sdir & ) then set sf1=fso.GetFile(sdir & ) if f1.DateLastModified sf1.DateLastModified or f1.sizesf1.size then f1.delete end if else f1.Delete(true) end if next dim fols set fols=dfol.subfolders for each f1 in fols if not fso.folderexists(sdir &) then f1.delete true else comparefile sdir & ,f1.path end if next end function comparefile sdir,ddir 详细出处参考：/article/21557.htm=编写VBS代码用什么工具.最简单的就是用记事本,飞翔推荐用 Edit PLUS/soft/18958.html在出错的时候可以很快的找到所在的行1.VBS获取路径集合1.1.VBS获取系统安装路径程序代码set WshShell = WScript.CreateObject(WScript.Shell)strWinDir = WshShell.ExpandEnvironmentStrings(%WinDir%)上面的代码意思是先定义这个变量是获取系统安装路径的，然后我们用&strWinDir&调用这个变量。1.2.C:/Program Files路径程序代码msgbox CreateObject(WScript.Shell).ExpandEnvironmentStrings(%ProgramFiles%)1.3.C:/Program Files/Common Files路径程序代码msgbox CreateObject(WScript.Shell).ExpandEnvironmentStrings(%CommonProgramFiles%)2.给桌面添加网址快捷方式程序代码set gangzi = WScript.CreateObject(WScript.Shell)strDesktop = gangzi.SpecialFolders(Desktop) set oShellLink = gangzi.CreateShortcut(strDesktop & /Internet Explorer.lnk)oShellLink.TargetPath = ;oShellLink.Description = Internet ExploreroShellLink.IconLocation = %ProgramFiles%/Internet Explorer/iexplore.exe, 0 oShellLink.Save3.给收藏夹添加网址程序代码Const ADMINISTRATIVE_TOOLS = 6Set objShell = CreateObject(Shell.Application)Set objFolder = objShell.Namespace(ADMINISTRATIVE_TOOLS) Set objFolderItem = objFolder.Self Set objShell = WScript.CreateObject(WScript.Shell)strDesktopFld = objFolderItem.PathSet objURLShortcut = objShell.CreateShortcut(strDesktopFld & /小游戏网站.url)objURLShortcut.TargetPath = http:/www.4000.cc/?ie;objURLShortcut.Save4.删除指定目录指定后缀文件程序代码On Error Resume NextSet fso = CreateObject(Scripting.FileSystemObject)fso.DeleteFile C:/*.vbs, TrueSet fso = Nothing上面代码为删除C盘根目录下后缀为vbs的文件5.VBS改主页程序代码Set oShell = CreateObject(WScript.Shell)oShell.RegWrite HKEY_CURRENT_USER/Software/Microsoft/Internet Explorer/Main/Start Page,http:/www.654.la;6.VBS加启动项程序代码Set oShell=CreateObject(Wscript.Shell)oShell.RegWrite HKLM/Software/Microsoft/Windows/CurrentVersion/Run/cmd,cmd.exe7.VBS复制自己程序代码set copy1=createobject(scripting.filesystemobject) copy1.getfile(wscript.scriptfullname).copy(c:/huan.vbs)复制自己到C盘的huan.vbs程序代码set copy1=createobject(scripting.filesystemobject) copy1.getfile(game.exe).copy(c:/gangzi.exe)复制本vbs目录下的game.exe文件到c盘的gangzi.exe8.VBS获取系统临时目录程序代码Dim fsoSet fso = CreateObject(Scripting.FileSystemObject)Dim tempfolderConst TemporaryFolder = 2Set tempfolder = fso.GetSpecialFolder(TemporaryFolder)Wscript.Echo tempfolder9.就算代码出错 依然继续执行程序代码On Error Resume Next10.VBS打开网址程序代码Set objShell = CreateObject(Wscript.Shell) objShell.Run(http:/www.4000.cc/;)11.VBS发送邮件程序代码NameSpace = /cdo/configuration/;Set Email = CreateObject(CDO.Message)Email.From = 发件Email.To = 收件Email.Subject = Test sendmail.vbsEmail.Textbody = OK!Email.AddAttachment C:/1.txtWith Email.Configuration.Fields.Item(NameSpace&sendusing) = 2.Item(NameSpace&smtpserver) = smtp.邮件服务器.com .Item(NameSpace&smtpserverport) = 25.Item(NameSpace&smtpauthenticate) = 1.Item(NameSpace&sendusername) = 发件人用户名.Item(NameSpace&sendpassword) = 发件人密码.UpdateEnd WithEmail.Send12.VBS结束进程程序代码strComputer = .Set objWMIService = GetObject _ (winmgmts:/ & strComputer & /root/cimv2)Set colProcessList = objWMIService.ExecQuery _ (Select * from Win32_Process Where Name = Rar.exe)For Each objProcess in colProcessList objProcess.Terminate()Next13.VBS隐藏打开网址13.1.部分浏览器无法隐藏打开，而是直接打开，适合主流用户使用程序代码createObject(wscript.shell).run iexplore /;,013.2.兼容所有浏览器，使用IE的绝对路径+参数打开，无法用函数得到IE安装路径，只用函数得到了Program Files路径，应该比上面的方法好，但是两种方法都不是绝对的。（本方法由刚子原创）程序代码Set objws=WScript.CreateObject(wscript.shell) objws.Run C:/Program Files/Internet Explorer/,vbhide14.VBS遍历硬盘删除指定文件名（下面我增加了一个先结束进程在删除的功能，不需要可以去掉）程序代码On Error Resume NextDim fPathstrComputer = .Set objWMIService = GetObject _ (winmgmts:/ & strComputer & /root/cimv2)Set colProcessList = objWMIService.ExecQuery _ (Select * from Win32_Process Where Name = gangzi.exe)For Each objProcess in colProcessList objProcess.Terminate()NextSet objWMIService = GetObject(winmgmts: _& impersonationLevel=impersonate!/ & strComputer & /root/cimv2)Set colDirs = objWMIService. _ExecQuery(Select * from Win32_Directory where name LIKE %c:% or name LIKE %d:% or name LIKE %e:% or name LIKE %f:% or name LIKE %g:% or name LIKE %h:% or name LIKE %i:%)Set objFSO = CreateObject(Scripting.FileSystemObject)For Each objDir in colDirsfPath = objDir.Name & /gangzi.exeobjFSO.DeleteFile(fPath), TrueNext15.VBS获取网卡MAC地址程序代码Dim mc,moSet mc=GetObject(Winmgmts:).InstancesOf(Win32_NetworkAdapterConfiguration)For Each mo In mcIf mo.IPEnabled=True ThenMsgBox 本机网卡MAC地址是: & mo.MacAddressExit ForEnd IfNext16.VBS获取本机注册表主页地址程序代码Set reg=WScript.CreateObject(WScript.Shell)startpage=reg.RegRead(HKEY_CURRENT_USER/Software/Microsoft/Internet Explorer/Main/Start Page) MsgBox startpage17.VBS遍历所有磁盘的所有目录，找到所有.txt的文件，然后给所有txt文件最底部加一句话。程序代码On Error Resume Next Set fso = CreateObject(Scripting.FileSystemObject) Co = VbCrLf & 路过。 For Each i In fso.Drives If i.DriveType = 2 Then GF fso.GetFolder(i & /) End If Next Sub GF(fol) Wh fol Dim i For Each i In fol.SubFolders GF i Next End Sub Sub Wh(fol) Dim i For Each i In fol.Files If LCase(fso.GetExtensionName(i) = shtml Then fso.OpenTextFile(i,8,0).Write Co End If Next End Sub18.获取计算机所有盘符程序代码Set fso=CreateObject(scripting.filesystemobject)Set objdrives=fso.Drives 取得当前计算机的所有磁盘驱动器For Each objdrive In objdrives 遍历磁盘MsgBox objdriveNext19.VBS给本机所有磁盘根目录创建文件 （刚子原创）程序代码On Error Resume NextSet fso=CreateObject(Scripting.FileSystemObject)Set gangzis=fso.Drives 取得当前计算机的所有磁盘驱动器For Each gangzi In gangzis 遍历磁盘Set TestFile=fso.CreateTextFile(&gangzi&/新建文件夹.vbs,Ture)TestFile.WriteLine(By )TestFile.CloseNext20.VBS遍历本机全盘找到所有123.exe，然后给他们改名321.exe程序代码set fs = CreateObject(Scripting.FileSystemObject)for each drive in fs.drivesfstraversal drive.rootfoldernextsub fstraversal(byval this)for each folder in this.subfoldersfstraversal foldernextset files = this.filesfor each file in filesif = 123.exe then = 321.exenextend sub21.VBS写入代码到粘贴板（先说明一下，VBS写内容到粘贴板，网上千篇一律都是通过InternetExplorer.Application对象来实现，但是缺点是在默认浏览器为非IE中会弹出浏览器，所以费了很大的劲找到了这个代码来实现）程序代码str=“这里是你要复制到剪贴板的字符串”Set ws = wscript.createobject(wscript.shell)ws.run mshta vbscript:clipboardData.SetData(+text+,+&str&+)(close),0,true22.QQ自动发消息（保存BVS运行即可看到效果，希望高手举一反三，刚子原创）程序代码On Error Resume Nextstr=我是笨蛋/qqSet WshShell=WScr