vbs代码,纯自己采集,绝对良心!

青丝 2,010 阅读

多段vbs代码,大家可借鉴,提意见或建议!
vbs代码,纯自己采集,绝对良心!vbs代码,纯自己采集,绝对良心!

工具/材料

windows电脑一台

操作方法

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)

OnError Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")

extFile = fso.GetExtensionName(file)

If file.Size = 0 And extFile = extThen

ReportEmpty file

End If

End Sub

'/// 写入日志文件
FunctionReportEmpty(file)
On Error Resume Next

response = MsgBox("我们在" & vbCr & file.Path & "发现了空文件," &_
"你想删除吗?", vbYesNo + vbDefaultButton1,"提示")

If vbyes = response Then

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

logbook.WriteLinefile.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.WriteLinefolderobj.path & vbCrlf & " 在 " & Now & " 被删除"

folderobj.delete

elseif response=vbCancel Then

MsgBox "你选择了退出!谢谢使用" & vbCrLf & "(c) Zero 2014"

WScript.Quit

end If

end Sub

23

此指南个别借鉴网络其他大神的作品并做了修改!
在此不必全部提出。
谢谢大家!

好了,以上就是大致内容了,(END)

个人积累的代码,网上许多都是重复的。如内含有错误,欢迎大神们指正!

相关推荐
热门推荐
分享