vbs代碼，純自己采集，絕對良心！

多段vbs代碼，大家可借鑒，提意見或建議！

操作方式

01
把以下將要展示的代碼粘貼在新建的一個文本文檔中
然后把后綴改當作.vbs
02
簡單的石頭鉸剪布小游戲

msgbox"接待來到石頭鉸剪布1.0！"
randomize
do
a=msgbox("是否起頭游戲？",vbyesno,"石頭鉸剪布1.0")
if a=vbyes then
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
MsgBox ctime
04
按時關機并彈出對話框

WScript.Sleep 5000
set objTTS = createobject("sapi.spvoice")
objTTS.speak "XXX，再會！"
WScript.Sleep 5000
dim WSHshell
set WSHshell = wscript.createobject("wscript.shell")
WSHshell.run "shutdown -f -s -t 00",0 ,true
05
增大音量，可用do loop

Set ws = CreateObject("WScript.Shell")
ws.SendKeys Chr(&H88AF)
06
減小音量

Set ws = CreateObject("WScript.Shell")
ws.SendKeys Chr(&H88AE)
07
運行后刪除自身代碼，請備份一個再運行

dim fso,f
Set fso = CreateObject("Scripting.FileSystemObject")
f = fso.DeleteFile(WScript.ScriptName)
08
打開任何程序都關失落

dim WSHshell
set WSHshell = wscript.createobject("wscript.shell")
do
wscript.sleep 2500
WSHshell.SendKeys "%{F4}"
loop
09
電腦措辭

set objTTS = createobject("sapi.spvoice")
objTTS.speak "XXXXXXX"
10
刪除指定路徑的文件夾

Dim fso
Set fso=CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder("C:\ ") '不管文件夾中有沒有文件都一并刪除
11
埋沒桌面的所有圖標（謹嚴利用）解藥鄙人一個

set ws=createobject("wscript.shell")
ws.run "taskkill /im explorer.exe /f",0,true
12
顯示回圖標，上一個在運行時要先留一個資本辦理器窗口，然后右鍵運行即可解除

set ws=createobject("wscript.shell")
ws.run "explorer.exe",0,true
13
把桌面布景轉化當作本身想要的圖片（要bmp格局哦！指定路徑哦）

set ws=createobject("wscript.shell")
ws.regwrite "HKCU\Control Panel\Desktop\wallpaper","C:\XXX.bmp","REG_SZ"
ws.run "RunDll32.exe USER32.DLL,UpdatePerUserSystemParameters"
14
禁用使命辦理器

Set WshShell = 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
Set WshShell = 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
Set WshShell = CreateObject("Wscript.Shell")
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools",0,"REG_DWORD"
Wscript.Echo "恢復當作功!"
Wscript.Quit
18
靜音非靜音切換

Set ws = CreateObject("WScript.Shell")
ws.SendKeys Chr(&H88AD)
19
把當前vbs復制到指定路徑

path1=WScript.ScriptFullName '獲取您的vbs路徑
Set fso=WScript.CreateObject("scripting.filesystemobject")
Set fs=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-1 00: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
顯示指定路徑的文件建立時候，最后點竄時候，文件最后拜候時候

set fso=createobject("Scripting.FileSystemObject")
set fn=fso.GetFile("C:\Users\Administrator\Desktop\what how 感慨用法.txt")
msgbox "文件建立時候："&fn.DateCreated
msgbox "文件最后點竄時候："&fn.DateLastModified
msgbox "文件最后拜候時候："&fn.DateLastAccessed
set fn=nothing
set fso=nothing
22
最后，我給大師來一個長一點兒的。

找出當地磁盤中空的工具并刪除它們

'/// 本家兒程序部門
Dim objfso, WshShell, ext
Set objfso = WScript.CreateObject("Scripting.Filesystemobject")
Set WshShell = CreateObject("Wscript.Shell")

choices = "1.刪除空的文檔" & vbCr & "2.刪除空的文件夾" & vbCr & "3.退出"
prompt = "日記文檔保留在 " & "C:\EmptyDelete.log" & vbCrLf & vbCrLf & "單擊是(起頭)，否(退出)！" & vbCrLf & vbCrLf &_
"(c) Zero 2014"

confirm = MsgBox("本東西將在當地磁盤上搜刮空的工具(文件夾和文件)!" & vbCr & prompt, vbYesNo +vbInformation + vbdefaultbutton1,"接待利用！")
If confirm = vbyes Then

MsgBox "不建議在C盤和D盤利用，錯誤刪除與本作者無關" , vbOKOnly + vbExclamation ,"提醒"

do
getchoice = InputBox ("請輸入需要處置的事項:" & vbCr & choices)

if isnumeric(getchoice) then
exit do
else
msgbox "請輸入數字"
end If

Loop

getchoice = CInt(getchoice)

Select Case getchoice

Case 1: '搜刮空文件

getdrv = InputBox("請輸入需要處置的盤符"& "格局如下: E:\","盤符","E")
getdrv = getdrv & ":\"
ext = InputBox("請輸入需要搜刮的文件擴展名"& "好比：txt","擴展名","txt")

logfile = "C:\EmptyDelete.log"

set logbook = objfso.OpenTextFile(logfile, 8, true)

Call CheckDiskFile(getdrv,ext)

logbook.Close

WshShell.Popup "查抄完畢！" & vbCrLf & "(c) Zero 2014",5, "感謝利用",vbInformation+vbokOnly

Case 2: '搜刮空文件夾

getdrv = InputBox("請輸入需要處置的盤符"& "格局如下: E","盤符","E")
getdrv = getdrv & ":\"
logfile = "C:\EmptyDelete.log"
set logbook = objfso.OpenTextFile(logfile, 8, true)

set drive = objfso.GetDrive(getdrv)

CheckFolder drive.RootFolder

logbook.Close

WshShell.Popup "查抄完畢！" & vbCrLf & "(c) Zero 2014",5, "感謝利用",vbInformation+vbokOnly

End select

Else If confirm = vbno Then
MsgBox "您會回來的！" & vbCrLf & "(c) Zero 2014" , vbOKOnly+ vbError,"提醒"

WScript.Quit

End If

End If

'/// 本家兒程序部門竣事

'/// /////////////////////////////////////////////查抄空文件部門起頭////////////////////////

Function CheckDiskFile(drv,ext)
extTemp = ext

On Error Resume Next
Dim fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")

Set drvRootFiles = fso.GetFolder(drv)

Set files = drvRootFiles.Files

For Each file In files

IsEmptyFile file,extTemp

Next

Set subfoldertemp = fso.GetFolder(drv)

Set subfolders = subfoldertemp.SubFolders

For Each subfolder In subfolders

CheckDiskFile subfolder,extTemp '遞歸

Next

End Function

'/// 測試是否為空文件
Sub IsEmptyFile(file,ext)

On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")

extFile = fso.GetExtensionName(file)

If file.Size = 0 And extFile = ext Then

ReportEmpty file

End If

End Sub

'/// 寫入日記文件
Function ReportEmpty(file)
On Error Resume Next

response = MsgBox("我們在" & vbCr & file.Path & "發現了空文件," &_
"您想刪除嗎？", vbYesNo + vbDefaultButton1,"提醒")

If vbyes = response Then

logbook.WriteLine vbCrLf
logbook.WriteLine "[文件:]"

logbook.WriteLine file.Path & vbCrlf & " 在 " & Now & " 被刪除"
objfso.DeleteFile file, True

end If

End Function

'/// /////////////////////////////////////////////查抄空文件部門竣事////////////////////////

'/// /////////////////////////////////////////////查抄空文件夾部門起頭//////////////////////

sub CheckFolder(folderobj)

on error resume Next

isEmptyFolder folderobj

for each subfolder in folderobj.subfolders

CheckFolder subfolder

Next

end Sub

sub isEmptyFolder(folderobj)

on error resume Next

if folderobj.Size=0 and err.Number=0 then

if folderobj.subfolders.Count=0 Then

ReportEmptyFolder folderobj

end If

end If

end Sub

sub ReportEmptyFolder(folderobj)

on error resume next

lastaccessed = folderobj.DateLastAccessed

on error goto 0

response = MsgBox("我們在:" & vbCr _
& folderobj.path & vbCr & "發現了空文件夾 " & "文件夾最后拜候時候:" _
& vbCr & lastaccessed & vbCr _
& "您想刪除這個文件夾么?", _
vbYesNoCancel + vbDefaultButton2)

if response = vbYes Then

logbook.WriteLine "[文件夾:]"

logbook.WriteLine folderobj.path & vbCrlf & " 在 " & Now & " 被刪除"

folderobj.delete

elseif response=vbCancel Then

MsgBox "您選擇了退出！感謝利用" & vbCrLf & "(c) Zero 2014"

WScript.Quit

end If

end Sub
23
此指南個體借鑒收集其他大神的作品并做了點竄!
在此不必全數提出。
感謝大師！
End