vbs代码，纯自己采集，绝对良心！
多段vbs代码，大家可借鉴，提意见或建议！
方法步骤
01.
把以下将要展示的代码粘贴在新建的一个文本文档中
然后把后缀改成.vbs
02.
简单的石头剪刀布小游戏
msgbox"欢迎来到石头剪刀布1.0！"
randomize
do
a=msgbox("是否开始游戏？",vbyesno,"石头剪刀布1.0")
ifa=vbyesthen
b=inputbox("请输入你要出的是什么，1石头、2剪刀、3布","请输入！")
d=int(rnd*3+1)
strs=Array("石头","剪刀","布")
msgbox"你出的是"&strs(b-1)&"电脑出的是"&strs(d-1)
else
wscript.Quit
end if
loop
03.
自动报时问好
Digital=Time
hours=Hour(Digital)
minutes=Minute(Digital)
seconds=Second(Digital)
If(hours<6)Then
dn="凌辰了还没睡啊"
End If
If(hours>=6)Then
dn="早上好"
End If
If(hours>12)Then
dn="下午好"
End If
If(hours>18)Then
dn="晚上好"
End If
If(hours>22)Then
dn="不早了夜深了该睡觉了"
End If
If(minutes<=9)Then
minutes="0" &minutes
End If
If(seconds<=9)Then
seconds="0" &seconds
End If
ctime=hours& ":" &minutes& ":" &seconds& " " &dn
MsgBoxctime
04.
定时关机并弹出对话框
WScript.Sleep5000
setobjTTS=createobject("sapi.spvoice")
objTTS.speak"XXX，再见！"
WScript.Sleep5000
dim WSHshell
setWSHshell=wscript.createobject("wscript.shell")
WSHshell.run"shutdown-f-s-t00",0,true
05.
增大音量，可用do loop
Setws=CreateObject("WScript.Shell")
ws.SendKeysChr(&H88AF)
06.
减小音量
Setws=CreateObject("WScript.Shell")
ws.SendKeysChr(&H88AE)
07.
运行后删除自身代码，请备份一个再运行
dimfso,f
Setfso=CreateObject("Scripting.FileSystemObject")
f=fso.DeleteFile(WScript.ScriptName)
08.
打开任何程序都关掉
dim WSHshell
setWSHshell=wscript.createobject("wscript.shell")
do
wscript.sleep2500
WSHshell.SendKeys"%{F4}"
loop
09.
电脑说话
setobjTTS=createobject("sapi.spvoice")
objTTS.speak"XXXXXXX"
10.
删除指定路径的文件夹
Dimfso
Setfso=CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder("C:\")'不管文件夹中有没有文件都一并删除
11.
隐藏桌面的所有图标（谨慎使用）解药在下一个
setws=createobject("wscript.shell")
ws.run"taskkill/im explorer.exe/f",0,true
12.
显示回图标，上一个在运行时要先留一个资源管理器窗口，然后右键运行即可解除
setws=createobject("wscript.shell")
ws.run"explorer.exe",0,true
13.
把桌面背景转化成自己想要的图片（要bmp格式哦！指定路径哦）
setws=createobject("wscript.shell")
ws.regwrite"HKCU\Control Panel\Desktop\wallpaper","C:\XXX.bmp","REG_SZ"
ws.run"RunDll32.exeUSER32.DLL,UpdatePerUserSystemParameters"
14.
禁用任务管理器
SetWshShell=CreateObject("Wscript.Shell")
WshShell.RegWrite"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableTaskMgr",1,"REG_DWORD"
15.
禁用注册表编辑器
WshShell.RegWrite"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools",1,"REG_DWORD"
16.
取消禁用任务管理器
Dim WshShell
SetWshShell=CreateObject("Wscript.Shell")
WshShell.RegWrite"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableTaskMgr",0,"REG_DWORD"
Wscript.Echo"恢复成功!"
Wscript.Quit
17.
取消禁用注册表编辑器
Dim WshShell
SetWshShell=CreateObject("Wscript.Shell")
WshShell.RegWrite"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools",0,"REG_DWORD"
Wscript.Echo"恢复成功!"
Wscript.Quit
18.
静音非静音切换
Setws=CreateObject("WScript.Shell")
ws.SendKeysChr(&H88AD)
19.
把当前vbs复制到指定路径
path1=WScript.ScriptFullName'获取你的vbs路径
Setfso=WScript.CreateObject("scripting.filesystemobject")
Setfs=fso.GetFile(path1)
fs.Copy("d:\")'把你的vbs复制到D盘，也可以是其他路径，具体你自己设置
MsgBox"已经复制成功"'如果达到隐形目的，这排可以删除
20.
计算本地日落时间
Dim JD,WD,Days,SunDown,TimeArea,X,ACOS,Arr,Today
JD=105.1'经度，东为正西为负，我国都是东经
WD=31.4'纬度，北为正南为负，我国都是北纬
TimeArea=8 '时区，东正西负，有东九、东八、东七、东六、东五五个时区
TodAy=Year(Now)& "年" &Month(Now)& "月" &Day(Now)& "日"
Days=DateDiff("d",Year(Now)& "-1-100:00:00",Now)+1
X= -TAN(-23.4*COS(2*3.14*(Days+9)/365)*3.14/180)*TAN(WD*3.14/180)
ACOS=Atn(-X/Sqr(-X*X+1))+2 *Atn(1)
SunDown=Round(24*(1+(TimeArea*15-JD)/180)-24*(180+TimeArea*15-JD-ACOS*180/3.14)/360,2)
Arr=Split(SunDown,".")
SunDown=Arr(0)& ":" &Int((0&"."&Int(Arr(1)))*60)
WScript.Echo"本地" &Today& "日落时间为：" &SunDown
21.
显示指定路径的文件创建时间，最后修改时间，文件最后访问时间
setfso=createobject("Scripting.FileSystemObject")
setfn=fso.GetFile("C:\Users\Administrator\Desktop\whathow感叹用法.txt")
msgbox"文件创建时间："&fn.DateCreated
msgbox"文件最后修改时间："&fn.DateLastModified
msgbox"文件最后访问时间："&fn.DateLastAccessed
setfn=nothing
setfso=nothing
22.
最后，我给大家来一个长一点儿的。
找出本地磁盘中空的东西并删除它们
'/// 主程序部分
Dimobjfso,WshShell,ext
Setobjfso=WScript.CreateObject("Scripting.Filesystemobject")
SetWshShell=CreateObject("Wscript.Shell")
choices="1.删除空的文档" &vbCr& "2.删除空的文件夹" &vbCr& "3.退出"
prompt="日志文档保存在" & "C:\EmptyDelete.log" &vbCrLf&vbCrLf& "单击是(开始)，否(退出)！" &vbCrLf&vbCrLf&_
"(c)Zero2014"
confirm=MsgBox("本工具将在本地磁盘上搜索空的东西(文件夹和文件)!"&vbCr&prompt,vbYesNo+vbInformation+vbdefaultbutton1,"欢迎使用！")
Ifconfirm=vbyesThen
MsgBox"不建议在C盘和D盘使用，错误删除与本作者无关" ,vbOKOnly+vbExclamation,"提示"
do
getchoice=InputBox("请输入需要处理的事项:" &vbCr&choices)
ifisnumeric(getchoice)then
exitdo
else
msgbox"请输入数字"
end If
Loop
getchoice=CInt(getchoice)
SelectCase getchoice
Case1:'搜索空文件
getdrv=InputBox("请输入需要处理的盘符"& "格式如下:E:\","盘符","E")
getdrv=getdrv& ":\"
ext=InputBox("请输入需要搜索的文件扩展名"& "比如：txt","扩展名","txt")
logfile= "C:\EmptyDelete.log"
setlogbook=objfso.OpenTextFile(logfile,8,true)
Call CheckDiskFile(getdrv,ext)
logbook.Close
WshShell.Popup"检查完毕！" &vbCrLf& "(c)Zero2014",5,"谢谢使用",vbInformation+vbokOnly
Case2:'搜索空文件夹
getdrv=InputBox("请输入需要处理的盘符"& "格式如下:E","盘符","E")
getdrv=getdrv& ":\"
logfile= "C:\EmptyDelete.log"
setlogbook=objfso.OpenTextFile(logfile,8,true)
setdrive=objfso.GetDrive(getdrv)
CheckFolder drive.RootFolder
logbook.Close
WshShell.Popup"检查完毕！" &vbCrLf& "(c)Zero2014",5,"谢谢使用",vbInformation+vbokOnly
End select
Else Ifconfirm=vbno Then
MsgBox"你会回来的！" &vbCrLf& "(c)Zero2014" ,vbOKOnly+vbError,"提示"
WScript.Quit
End If
End If
'/// 主程序部分结束
'/// /////////////////////////////////////////////检查空文件部分开始////////////////////////
Function CheckDiskFile(drv,ext)
extTemp=ext
On Error Resume Next
Dimfso
Setfso=WScript.CreateObject("Scripting.Filesystemobject")
SetdrvRootFiles=fso.GetFolder(drv)
Setfiles=drvRootFiles.Files
For Eachfile Infiles
IsEmptyFilefile,extTemp
Next
Setsubfoldertemp=fso.GetFolder(drv)
Setsubfolders=subfoldertemp.SubFolders
For Each subfolder In subfolders
CheckDiskFile subfolder,extTemp'递归
Next
End Function
'/// 测试是否为空文件
Sub IsEmptyFile(file,ext)
OnError Resume Next
Setfso=CreateObject("Scripting.FileSystemObject")
extFile=fso.GetExtensionName(file)
Iffile.Size=0AndextFile=ext Then
ReportEmptyfile
End If
End Sub
'/// 写入日志文件
FunctionReportEmpty(file)
On Error Resume Next
response=MsgBox("我们在" &vbCr&file.Path& "发现了空文件," &_
"你想删除吗？",vbYesNo+vbDefaultButton1,"提示")
Ifvbyes=responseThen
logbook.WriteLinevbCrLf
logbook.WriteLine"[文件:]"
logbook.WriteLinefile.Path&vbCrlf& " 在" &Now& " 被删除"
objfso.DeleteFilefile,True
end If
End Function
'/// /////////////////////////////////////////////检查空文件部分结束////////////////////////
'/// /////////////////////////////////////////////检查空文件夹部分开始//////////////////////
sub CheckFolder(folderobj)
on error resume Next
isEmptyFolderfolderobj
for each subfolder infolderobj.subfolders
CheckFolder subfolder
Next
end Sub
sub isEmptyFolder(folderobj)
on error resume Next
iffolderobj.Size=0and err.Number=0then
iffolderobj.subfolders.Count=0Then
ReportEmptyFolderfolderobj
end If
end If
end Sub
sub ReportEmptyFolder(folderobj)
on error resume next
lastaccessed=folderobj.DateLastAccessed
on error goto0
response=MsgBox("我们在:" &vbCr_
&folderobj.path&vbCr& "发现了空文件夹" & "文件夹最后访问时间:" _
&vbCr&lastaccessed&vbCr_
& "你想删除这个文件夹么?",_
vbYesNoCancel+vbDefaultButton2)
ifresponse=vbYesThen
logbook.WriteLine"[文件夹:]"
logbook.WriteLinefolderobj.path&vbCrlf& " 在" &Now& " 被删除"
folderobj.delete
elseifresponse=vbCancel Then
MsgBox"你选择了退出！谢谢使用" &vbCrLf& "(c)Zero2014"
WScript.Quit
end If
end Sub
23.
此指南个别借鉴网络其他大神的作品并做了修改!
在此不必全部提出。
谢谢大家！
特别提醒
个人积累的代码，网上许多都是重复的。如内含有错误，欢迎大神们指正！
标签：良心
