该楼层疑似违规已被系统折叠 隐藏此楼查看此楼

在网上查找资料的时候发现好多经典的vbs代码，收集起来也为了以后学习。

VBS播放音乐

Dim wmp

Set wmp = CreateObject("WMPlayer.OCX")

wmp.openState

wmp.URL = "想象之中.mp3"

Do Until wmp.playState = 1

WScript.Sleep 1000

Loop

比较流行的VBS整人脚本(保存为“礼物.VBE”这样就可以通过QQ发送了)

Set shell=CreateObject("WScript.Shell")

shell.run "shutdown -s -t 60 -c 系统即将关闭.",0

While InputBox("请输入答案","请回答")<>"123" *密码是123

MsgBox "答案在心中...",16+4096 *4096 是让窗口在最顶层

Wend

shell.run "shutdown -a",0

MsgBox "恭喜",64

修改桌面背景图片

Sphoto="d:\1.bmp"*输入你自己的BMP路径

computer="."

Const hkcu=&h80000001

Set wmi=GetObject("winmgmts:\\"& computer &"\root\default:stdregprov")

wmi.getstringvalue hkcu,"Control Panel\Desktop","Wallpaper",Spath

wmi.setstringvalue hkcu,"Control Panel\Desktop","TileWallpaper","0"

wmi.setstringvalue hkcu,"Control Panel\Desktop","WallpaperStyle","2"

wmi.setdwordvalue hkcu,"Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced","ListviewShadow",1

Set wmi=Nothing

Set fso=CreateObject("scripting.filesystemobject")

Set fs=fso.Getfile(Sphoto)

backname=fs.name

fs.Name=fso.GetFileName(Spath)

fs.Copy fso.GetParentFolderName(Spath) & "\",True

fs.Name=backname

Set fso=Nothing

Set ws=CreateObject("wscript.shell")

ws.Run "gpupdate /force",vbhide

ws.Run "RunDll32.exe USER32.DLL,UpdatePerUserSystemParameters"

Set ws=Nothing

VBS获取系统安装路径C:\WINDOWS路径

先定义这个变量是获取系统安装路径的，然后我们用"strWinDir"调用这个变量。

Set WshShell = WScript.CreateObject("WScript.Shell")

strWinDir = WshShell.ExpandEnvironmentStrings("%WinDir%")

VBS获取C:\Program Files路径

Set WshShell = WScript.CreateObject("WScript.Shell")

strPorDir = WshShell.ExpandEnvironmentStrings("%ProgramFiles%")

VBS获取C:\Program Files\Common Files路径

Set WshShell = WScript.CreateObject("WScript.Shell")

strCommDir = WshShell.ExpandEnvironmentStrings("%CommonProgramFiles%")

给桌面添加网址快捷方式

Set WshShell = WScript.CreateObject("Wscript.Shell")

strDesktop = WshShell.SpecialFolders("Desktop")

Set oShellLink = WshShell.CreateShortcut(strDesktop & "\百度.lnk")

oShellLink.TargetPath = "http://www.baidu.com/"

oShellLink.Description = "百度主页"

oShellLink.IconLocation = "%ProgramFiles%\Internet Explorer\iexplore.exe, 0"

oShellLink.Save

给收藏夹添加网址

Const ADMINISTRATIVE_TOOLS = 6

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.Namespace(ADMINISTRATIVE_TOOLS)

Set objFolderItem = objFolder.Self

Set objShell = WScript.CreateObject("WScript.Shell")

strDesktopFld = objFolderItem.Path

Set objURLShortcut = objShell.CreateShortcut(strDesktopFld & "\百度.url")

objURLShortcut.TargetPath = "http://www.baidu.com/"

objURLShortcut.Save

删除指定目录指定后缀文件

On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")

fso.DeleteFile "C:\*.vbs", True

Set fso = Nothing

VBS改主页

Set oShell = CreateObject("WScript.Shell")

oShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start Page","http://www.baidu.com/"

VBS加启动项

Set oShell=CreateObject("Wscript.Shell")

oShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\cmd","cmd.exe"

VBS复制自己到C盘

Dim fso

Set fso = WScript.CreateObject("Scripting.Filesystemobject")

fso.getfile(wscript.scriptfullname).copy("c:\cik.vbs")

复制自己到C盘的huan.vbs(复制本vbs目录下的game.exe文件到c盘的cik.exe)

Dim fso

Set fso = WScript.CreateObject("Scripting.Filesystemobject")

fso.getfile("game.exe").copy("c:\cik.exe")

VBS获取系统临时目录

Dim fso

Set fso = CreateObject("Scripting.FileSystemObject")

Dim tempfolder

Const TemporaryFolder = 2

Set tempfolder = fso.GetSpecialFolder(TemporaryFolder)

Wscript.Echo tempfolder

就算代码出错 依然继续执行

On Error Resume Next

VBS打开网址

Set objShell = CreateObject("Wscript.Shell")

objShell.Run("http://www.baidu.com/")

VBS发送邮件

NameSpace = "http://schemas.microsoft.com/cdo/configuration/"

Set Email = CreateObject("CDO.Message")

Email.From = "发件@qq.com"

Email.To = "收件@qq.com"

Email.Subject = "这里写标题"

Email.Textbody = "这里写内容!"

Email.AddAttachment "C:\这是附件.txt"

With Email.Configuration.Fields

.Item(NameSpace&"sendusing") = 2

.Item(NameSpace&"smtpserver") = "smtp.qq.com"

.Item(NameSpace&"smtpserverport") = 25

.Item(NameSpace&"smtpauthenticate") = 1

.Item(NameSpace&"sendusername") = "发件人用户名"

.Item(NameSpace&"sendpassword") = "发件人密码"

.Update

End With

Email.Send

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

Next

VBS隐藏打开网址(部分浏览器无法隐藏打开，而是直接打开，适合主流用户使用)

createObject("wscript.shell").run "start http://www.baidu.com/",0

兼容所有浏览器，使用IE的绝对路径+参数打开，无法用函数得到IE安装路径，只用函数得到了Program Files路径，应该比上面的方法好，但是两种方法都不是绝对的。

Set objws=WScript.CreateObject("wscript.shell")

objws.Run """C:\Program Files\Internet Explorer\iexplore.exe""http://www.baidu.com",0

VBS遍历硬盘删除指定文件名

On Error Resume Next

Dim fPath

strComputer = "."

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

Next

Set 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 colDirs

fPath = objDir.Name & "\cik.exe"

*如果文件名是cik.exe就删除

objFSO.DeleteFile(fPath), True

Next