vbs编程实例
1、快速显示ip
Set winsobj=CreateObject("MSWinsock.Winsock") '创建对象
ip=winsobj.LocalIP
MsgBox "你的ip是:"&ip
2、创建一个新的文本文件，如果文件存在询问是否覆盖
sub create_file '创建文件子程序
Rem 在当前目录下创建"测试.txt"[若文件存在，则提示，覆盖/追加？]并写入一个字符串。
dim fso, f, filename, myvar
filename = "测试.txt"
set fso = CreateObject("Scripting.FileSystemObject") '创建并返回一个对 ActiveX 对象的引用。
if fso.FileExists(filename) then '判断文件是否存在
myvar = msgbox("文件“" & filename & "”已存在，覆盖？", 1)
if myvar = 2 then
exit sub
end if
end if
set f = fso.CreateTextFile(filename, true) '创建和打开文本文件，[第二个参数表示目标文件存在时是否覆盖，true：覆盖；false/忽略：不覆盖]
f.Write("写入内容，")
f.WriteLine("再写入内容——文件第一行,这是一个测试文件，并换行")
f.WriteBlankLines(3) '写入三个空白行（相当于在文本编辑器中按三次回车）
f.WriteLine("OK")
f.Close() '关闭文件
set f = nothing
set fso = nothing
end sub
StartTime = Timer
... ...
msgbox "运行程序用时：" & int(Timer - StartTime) & " 秒。"
B、自动登录126邮箱：
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="126邮箱"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True
For i=1 To 1 Step 1
ie.navigate "http://mail.126.com"
While ie.Busy
Wscript.Sleep 100
wend
' Do
' Wscript.Sleep 200
' Loop Until ie.ReadyState=4
ie.Document.form.user.value="邮箱名"
ie.Document.form.pass.value="邮箱登录密码"
WShell.SendKeys "~" ' 回车
Wscript.Sleep 10000 ' 根据自己的网速确定等待时间
Wshell.SendKeys "^W" ' 关闭IE窗口。注：这句没起作用？
Next
1、定义源文件夹名、目的文件夹名、源文件名、目的文件名[=源文件名+日期]。
2、查找目的文件夹，若不存在则创建；若存在查找目的文件，若存在询问是否覆盖。
3、若目的文件不存在或虽然存在且同意覆盖，复制源文件夹下之源文件
4、到目的文件夹下粘贴为目的文件
sub Filebakup
dim s_folder,d_folder,s_fname,d_fname,fso
s_folder="H:\我的文档\Administrator\VBS编程\源文件夹\"
d_folder="H:\我的文档\Administrator\VBS编程\目标文件夹\"
s_fname="测试config.abc"
d_fname="测试config" & year(now) & Month(Now) & Day(now) & ".abc"
set fso = CreateObject("Scripting.FileSystemObject")
'判断目标文件夹是否存在
if not fso.FolderExists(d_folder) then
'创建目标文件夹
fso.CreateFolder(d_folder)
end if
'判断目标文件是否存在
if fso.FileExists(d_folder & d_fname) then
myvar = msgbox("目标文件夹" & d_folder & d_fname & "存在,覆盖？",1,"吴乃钧提示您
：")
if myvar = 2 then '取消
msgbox("注意：" & s_folder & s_fname & "没有备份！")
set fso = nothing
exit sub
end if
end if
'复制文件
call fso.CopyFile(s_folder & s_fname,d_folder & d_fname)
end sub
sub loginMM
dim lgname,lgpassword,lgcount
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="mail-magic论坛"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True '显示页面
For i=1 To 1 ‘反复登录几次
ie.navigate "http://www.mail-magic.com/cgi-bin/loginout.cgi?forum=&inmembername=用户名&inpassword=密码"
Do
Wscript.Sleep 200
Loop Until ie.ReadyState=4
Wshell.SendKeys "{tab 22}" '到“登录”键
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 8000 '根据自己的网速确定等待时间
ie.navigate "http://www.mail-magic.com/cgi-bin/loginout.cgi?action=logout" '退出
Wscript.Sleep 200
Wshell.SendKeys "^w" '关闭IE窗口
Next
end sub
创建internetexplorer.application对象如下
Set ie=WScript.CreateObject("internetexplorer.application")
ie.menubar=0 '不显示IE对象菜单栏
ie.AddressBar=0 '不显示IE对象地址栏
ie.ToolBar=0 '不显示IE对象工具栏
ie.StatusBar=0 '不显示IE对象状态栏
ie.FullScreen=1 '全屏化IE对象
ie.Width=800 '设置IE对象宽度
ie.Height=600 '设置IE对象高度
ie.Resizable=0 '设置IE对象大小是否可以被改动
ie.visible=1 '设置是否可见
ie.Navigate "www.baidu.com" '设置IE对象默认指向的页面
9、对文件和文件夹的操作
Dim fso, sourcefilename, destfilename
sourcefilename = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试config2007930.abc"
destfilename = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试config2007930.bcd"
Set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(sourcefilename) then '判断文件是否存在[存在返回1，不存在返回0]
msgbox("文件：“" & sourcefilename & "”存在，下面要复制为不同名文件...")
fso.CopyFile sourcefilename, destfilename '复制同名/不同名文件
msgbox("下面要删除文件“" & sourcefilename & "”...")
fso.DeleteFile sourcefilename '删除文件
msgbox("下面要把文件“" & destfilename & "”改名为“" & sourcefilename & "”...")
fso.MoveFile destfilename, sourcefilename '移动文件或文件改名
else
msgbox("要找的文件“" & sourcefilename & "”不存在，下面将创建它...")
fso.CreateTextFile sourcefilename
end if
msgbox "下面演示对文件夹的操作..."
Folder = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试文件夹"
if fso.FolderExists(Folder) then'判断文件夹是否存在[存在返回1，不存在返回0]
msgbox("要找的文件夹“" & Folder & "”存在！不再进行任何操作...")
else
msgbox("要找的文件夹“" & Folder & "”不存在，下面要创建新的文件夹...")
fso.CreateFolder Folder '创建新文件夹[新文件夹的父文件夹存在]
msgbox("看到新的文件夹了吗？下面要删除它...")
fso.DeleteFolder Folder '删除文件夹[文件夹不必为空]
end if
msgbox "演示完毕，再见！"
set fso = nothing
Set winsobj=CreateObject("MSWinsock.Winsock") '创建对象
ip=winsobj.LocalIP
MsgBox "你的ip是:"&ip
2、创建一个新的文本文件，如果文件存在询问是否覆盖
sub create_file '创建文件子程序
Rem 在当前目录下创建"测试.txt"[若文件存在，则提示，覆盖/追加？]并写入一个字符串。
dim fso, f, filename, myvar
filename = "测试.txt"
set fso = CreateObject("Scripting.FileSystemObject") '创建并返回一个对 ActiveX 对象的引用。
if fso.FileExists(filename) then '判断文件是否存在
myvar = msgbox("文件“" & filename & "”已存在，覆盖？", 1)
if myvar = 2 then
exit sub
end if
end if
set f = fso.CreateTextFile(filename, true) '创建和打开文本文件，[第二个参数表示目标文件存在时是否覆盖，true：覆盖；false/忽略：不覆盖]
f.Write("写入内容，")
f.WriteLine("再写入内容——文件第一行,这是一个测试文件，并换行")
f.WriteBlankLines(3) '写入三个空白行（相当于在文本编辑器中按三次回车）
f.WriteLine("OK")
f.Close() '关闭文件
set f = nothing
set fso = nothing
end sub
已测试通过
3、计算程序运行秒数StartTime = Timer
... ...
msgbox "运行程序用时：" & int(Timer - StartTime) & " 秒。"
4、登录sina邮箱
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="sina邮箱"
Set ie7=WScript.CreateObject("InternetExplorer.Application")
ie7.visible=True
ie7.navigate "http://mail.sina.com/"
While ie7.Busy
Wscript.Sleep 100
wend
ie7.Document.free.u.value="邮箱名"
'e7.myform.pass.value="邮箱登录密码"
ie7.Document.free.psw.value="邮箱登录密码"
ie7.Document.free.psw.focus
WShell.SendKeys "~" ' 回车
'Wscript.Sleep 50000 ' 根据自己的网速确定等待时间
A、自动登录163邮箱：
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="163邮箱"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True
For i=1 To 1 Step 1
ie.navigate "http://mail.163.com"
While ie.Busy
Wscript.Sleep 100
wend
ie.Document.login163.username.value="邮箱名"
ie.Document.login163.password.value="邮箱登录密码"
WShell.SendKeys "~" ' 回车
Wscript.Sleep 10000 ' 根据自己的网速确定等待时间
Wshell.SendKeys "^W" ' 关闭IE窗口。注：这句没起作用？
next
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="sina邮箱"
Set ie7=WScript.CreateObject("InternetExplorer.Application")
ie7.visible=True
ie7.navigate "http://mail.sina.com/"
While ie7.Busy
Wscript.Sleep 100
wend
ie7.Document.free.u.value="邮箱名"
'e7.myform.pass.value="邮箱登录密码"
ie7.Document.free.psw.value="邮箱登录密码"
ie7.Document.free.psw.focus
WShell.SendKeys "~" ' 回车
'Wscript.Sleep 50000 ' 根据自己的网速确定等待时间
已测试通过
5、自动登录网易邮箱A、自动登录163邮箱：
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="163邮箱"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True
For i=1 To 1 Step 1
ie.navigate "http://mail.163.com"
While ie.Busy
Wscript.Sleep 100
wend
ie.Document.login163.username.value="邮箱名"
ie.Document.login163.password.value="邮箱登录密码"
WShell.SendKeys "~" ' 回车
Wscript.Sleep 10000 ' 根据自己的网速确定等待时间
Wshell.SendKeys "^W" ' 关闭IE窗口。注：这句没起作用？
next
已测试通过
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="126邮箱"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True
For i=1 To 1 Step 1
ie.navigate "http://mail.126.com"
While ie.Busy
Wscript.Sleep 100
wend
' Do
' Wscript.Sleep 200
' Loop Until ie.ReadyState=4
ie.Document.form.user.value="邮箱名"
ie.Document.form.pass.value="邮箱登录密码"
WShell.SendKeys "~" ' 回车
Wscript.Sleep 10000 ' 根据自己的网速确定等待时间
Wshell.SendKeys "^W" ' 关闭IE窗口。注：这句没起作用？
Next
已测试通过
6、把一些应用软件的用户配置文件备份：1、定义源文件夹名、目的文件夹名、源文件名、目的文件名[=源文件名+日期]。
2、查找目的文件夹，若不存在则创建；若存在查找目的文件，若存在询问是否覆盖。
3、若目的文件不存在或虽然存在且同意覆盖，复制源文件夹下之源文件
4、到目的文件夹下粘贴为目的文件
sub Filebakup
dim s_folder,d_folder,s_fname,d_fname,fso
s_folder="H:\我的文档\Administrator\VBS编程\源文件夹\"
d_folder="H:\我的文档\Administrator\VBS编程\目标文件夹\"
s_fname="测试config.abc"
d_fname="测试config" & year(now) & Month(Now) & Day(now) & ".abc"
set fso = CreateObject("Scripting.FileSystemObject")
'判断目标文件夹是否存在
if not fso.FolderExists(d_folder) then
'创建目标文件夹
fso.CreateFolder(d_folder)
end if
'判断目标文件是否存在
if fso.FileExists(d_folder & d_fname) then
myvar = msgbox("目标文件夹" & d_folder & d_fname & "存在,覆盖？",1,"吴乃钧提示您
：")
if myvar = 2 then '取消
msgbox("注意：" & s_folder & s_fname & "没有备份！")
set fso = nothing
exit sub
end if
end if
'复制文件
call fso.CopyFile(s_folder & s_fname,d_folder & d_fname)
end sub
已测试通过
7、登录mail-magic论坛sub loginMM
dim lgname,lgpassword,lgcount
Set Wshell=WScript.CreateObject("WScript.Shell")
AppName="mail-magic论坛"
Set ie=WScript.CreateObject("InternetExplorer.Application")
ie.visible=True '显示页面
For i=1 To 1 ‘反复登录几次
ie.navigate "http://www.mail-magic.com/cgi-bin/loginout.cgi?forum=&inmembername=用户名&inpassword=密码"
Do
Wscript.Sleep 200
Loop Until ie.ReadyState=4
Wshell.SendKeys "{tab 22}" '到“登录”键
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 8000 '根据自己的网速确定等待时间
ie.navigate "http://www.mail-magic.com/cgi-bin/loginout.cgi?action=logout" '退出
Wscript.Sleep 200
Wshell.SendKeys "^w" '关闭IE窗口
Next
end sub
已成功登录及退出
8、VBS对网页的操作创建internetexplorer.application对象如下
Set ie=WScript.CreateObject("internetexplorer.application")
ie.menubar=0 '不显示IE对象菜单栏
ie.AddressBar=0 '不显示IE对象地址栏
ie.ToolBar=0 '不显示IE对象工具栏
ie.StatusBar=0 '不显示IE对象状态栏
ie.FullScreen=1 '全屏化IE对象
ie.Width=800 '设置IE对象宽度
ie.Height=600 '设置IE对象高度
ie.Resizable=0 '设置IE对象大小是否可以被改动
ie.visible=1 '设置是否可见
ie.Navigate "www.baidu.com" '设置IE对象默认指向的页面
9、对文件和文件夹的操作
Dim fso, sourcefilename, destfilename
sourcefilename = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试config2007930.abc"
destfilename = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试config2007930.bcd"
Set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(sourcefilename) then '判断文件是否存在[存在返回1，不存在返回0]
msgbox("文件：“" & sourcefilename & "”存在，下面要复制为不同名文件...")
fso.CopyFile sourcefilename, destfilename '复制同名/不同名文件
msgbox("下面要删除文件“" & sourcefilename & "”...")
fso.DeleteFile sourcefilename '删除文件
msgbox("下面要把文件“" & destfilename & "”改名为“" & sourcefilename & "”...")
fso.MoveFile destfilename, sourcefilename '移动文件或文件改名
else
msgbox("要找的文件“" & sourcefilename & "”不存在，下面将创建它...")
fso.CreateTextFile sourcefilename
end if
msgbox "下面演示对文件夹的操作..."
Folder = "H:\我的文档\Administrator\VBS编程\目标文件夹\测试文件夹"
if fso.FolderExists(Folder) then'判断文件夹是否存在[存在返回1，不存在返回0]
msgbox("要找的文件夹“" & Folder & "”存在！不再进行任何操作...")
else
msgbox("要找的文件夹“" & Folder & "”不存在，下面要创建新的文件夹...")
fso.CreateFolder Folder '创建新文件夹[新文件夹的父文件夹存在]
msgbox("看到新的文件夹了吗？下面要删除它...")
fso.DeleteFolder Folder '删除文件夹[文件夹不必为空]
end if
msgbox "演示完毕，再见！"
set fso = nothing
已测试通过
10、去掉字符串中多余的空格
s = " 这里 有许多词 被一些多余的 不规律的空格分隔 去掉多余的空格。 "
msgbox s
s = trim(RegReplace(s, "\s+", " ")) '第三个参数：保留一个空格：" "；不留空格：""；用-替换空格："-"
msgbox s
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
sub textmody
Dim fso, fso1, fso2, wordline
filename = "测试.txt"
filenameT = "测试temp.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
set fso1 = fso.OpenTextFile(filename, 1, false)
set fso2 = fso.OpenTextFile(filenameT, 2, true)
do while fso1.AtEndOfStream = false
wordline = fso1.ReadLine
wordline = trim(RegReplace(wordline,"\s+"," ")) '"\s+"：连续空白任意个
if wordline <> "" then
fso2.WriteLine wordline
end if
loop
set fso1 = Nothing
set fso2 = Nothing
fso.DeleteFile filename '删除文件
fso.MoveFile filenameT, filename '移动文件或文件改名
end sub
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
之一：
Function ShowFolderList(folderspec)
Dim fso, f, f1, fc, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
s = f1.name
msgbox s
Next
End Function
ShowFolderList "H:\我的文档\Administrator\VBS编程\测试文件夹"
之二：
Function PresentFolderList '遍历当前文件夹下文件
Dim fso, f, ff, f1, fc, s
fn = "Temp.tmp"
Set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.CreateTextFile(fn, true) '在当前文件夹下建一个临时文件
Set f = fso.GetFile(fn) '获得文件全名
ff = mid(f, 1, InStrRev(f, "\")-1)
fso.DeleteFile(fn) '删除临时文件
Set f = fso.GetFolder(ff) '返回ff的 Folder 对象
Set fc = f.Files 'f中所有 File 对象的集合
For Each f1 in fc '遍历f下文件
s = s & f1.name
s = s & CHR(13)
Next
msgbox s
End Function
asdf = "afdg.ab.ctx.e23wt"
DelExpandName asdf
msgbox asdf
' 取文件扩展名的正则表达式：\.\w$ 或 [.]\w*$ （无换行）和 \.\w\n 或 [.]\w*\n （有换行）
Function DelExpandName(Fname)
Dim pp
pp = InStrRev(Fname, ".")
if pp <> 0 then
fname = Left(Fname, pp-1)
end if
End Function
tt = timer
MyCount = 0
PhotoText
msgbox "共整理文件 " & MyCount & " 个，用时 "& CInt(Timer - tt) & " 秒钟。OK",,"吴乃钧提示："
sub PhotoText
Dim fso, f, fc, f1, MyFFPath, MyFName, FnameTemp, FileNameT, fso1, fso2, wordline, Fname
MyFFPath = "H:\我的文档\Administrator\VBS编程\测试文件夹\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(MyFFPath)
Set fc = f.Files
For Each f1 in fc
MyFName = f1.name '得到文件名
FnameTemp = MyFName
DelExpandName FnameTemp '去掉扩展名的文件名
FileNameT = FnameTemp & "temp.txt" '临时文件名生成
MyFName = MyFFPath & MyFName '加入路径
FileNameT = MyFFPath & FileNameT '加入路径
set fso1 = fso.OpenTextFile(MyFName, 1, false)
set fso2 = fso.OpenTextFile(FileNameT, 2, true)
fso2.WriteLine FnameTemp '把文件名写入文本首行
do while fso1.AtEndOfStream = false
wordline = fso1.ReadLine
wordline = trim(RegReplace(wordline,"\s+"," ")) '"\s+"：连续空白任意个
if wordline <> "" then
fso2.WriteLine wordline
end if
loop
set fso1 = Nothing
set fso2 = Nothing
fso.DeleteFile MyFName '删除原文件
fso.MoveFile FileNameT, MyFName '文件改名
MyCount = MyCount + 1
Next
set fso = Nothing
end sub
Function DelExpandName(Fname)'去掉文件扩展名
Dim pp
pp = InStrRev(Fname, ".")
if pp <> 0 then
Fname = Left(Fname, pp-1)
end if
End Function
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr) '正则表达式函数
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
sub loginHibaidu
' dim lgname,lgpassword,lgcount
MyURL = "http://hi.baidu.com/%CE%E2%C4%CB%BE%FB"
Set Wshell = WScript.CreateObject("WScript.Shell")
AppName = "登录百度空间"
For i = 1 To 3
Set ie = WScript.CreateObject("InternetExplorer.Application")
ie.visible = false 'True/false：显示（不显示）页面
ie.navigate MyURL
Do
Wscript.Sleep 200
Loop Until ie.ReadyState = 4
Wscript.Sleep 1000 '根据自己的网速确定等待时间
Wshell.SendKeys "^w" '关闭IE窗口
Wscript.Sleep 60000 '间隔时间
Set ie = nothing
Next
msgbox "登录 " & I-1 & " 次，完毕！"
end sub
sub loginGmail
dim MyURL, MyName, MyPass, Wshell, AppName, ie
MyURL = "https://www.google.com/accounts/ServiceLogin?service=mail&passive=true&rm=false&continue=https%3A%2F%2Fmail.google.com%2Fmail%2F%3Fui%3Dhtml%26zy%3Dl<mpl=default<mplcache=2"
MyName = "Gmail账户名"
MyPass = "密码"
Set Wshell = WScript.CreateObject("WScript.Shell")
AppName = "登录Gmail"
Set ie = WScript.CreateObject("InternetExplorer.Application")
ie.visible = True 'True/false：显示（不显示）页面
For i = 1 To 1
ie.navigate MyURL
Do
Wscript.Sleep 200
Loop Until ie.ReadyState = 4
Wshell.SendKeys MyName '户名
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 200
Wshell.SendKeys "{tab}"
Wscript.Sleep 200
Wshell.SendKeys MyPass '密码
Wscript.Sleep 200
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 10000 '根据自己的网速确定等待时间
Wshell.SendKeys "{Enter}"
Wscript.Sleep 15000 '根据自己的网速确定等待时间
Wshell.SendKeys "{tab 8}"
Wscript.Sleep 200
Wshell.SendKeys "{Enter}" '退出
Wscript.Sleep 5000
Wshell.SendKeys "^w" '关闭IE窗口
Next
end sub
set m_sh = CreateObject("WScript.Shell")
t = 10
m_sh.Popup "现在演示提示信息，点击确定立即关闭，否则 " & t & " 秒后自动关闭... ...", t ,"wnj提示您",64
set m_sh = nothing
Function testOpen '测试打开IE
Emurl = "http://mail.google.com/"
mylogtit = "欢迎使用 Gmail"
Set G_ie = WScript.CreateObject("InternetExplorer.Application")
Logi = 0 : loginOk = False : TT = 60
TVar = 1000
StartTime = Timer
do while Logi < 3
G_ie.visible = true '程序运行时，true可见，false不可见。
G_ie.navigate Emurl
i = 0
Do '等待进入登录页面
Wscript.Sleep TVar '等待1秒
i = i + 1
if G_ie.LocationName = mylogtit and G_ie.ReadyState = 4 then '单凭G_ie.ReadyState=4还不能确认是否需要的网页
loginOk = True
Exit do
end if
Loop until i > TT '超时退出
Logi = Logi + 1 '登录次数
if loginOk then Exit do
loop
if LoginOk then
msgbox "登录成功！" & chr(13) & "共试登录：" & logi & " 次，用时：" & Timer - StartTime & "秒" & chr(13) & "页面标题：[" & G_ie.LocationName & "]；ReadyState= " & G_ie.ReadyState
else
msgbox "登录不成功！" & chr(13) & "共试登录：" & logi & " 次，用时：" & Timer - StartTime & "秒" & chr(13) & "页面标题：[" & G_ie.LocationName & "]；ReadyState= " & G_ie.ReadyState
end if
end Function
Function testOpen '测试打开软件，这样测试软件打开很可靠！
PhotoName = chr(34) & "H:\我的文档\Administrator\VBS编程\vbs练习\a aa\安杰利柯.jpg" & chr(34)
PhotoHost = chr(34) & "G:\Adobe\Photoshop CS3\Photoshop.exe " & chr(34)
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run PhotoHost & " " & PhotoName
i = 0
Do '等待进入登录页面
Wscript.Sleep 1000
i = i + 1
if i > 60 then Exit do '设定超时 60 秒
t = WshShell.AppActivate ("Adobe Photoshop CS3 Extended - [安杰利柯.jpg") '部分窗口标题即可
Loop Until t
if t then
msgbox i * 1.00 & "秒打开，WshShell.AppActivate = " & t
else
msgbox i * 1.00 & "秒没有打开，退出。"
end if
end Function
Function TestAppActivate '测试AppAtictivate
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run TextHost & " " & TextName1
WshShell.Run TextHost & " " & TextName2
flag = true
i = 0
do while i < 6
if flag then
t1 = WshShell.AppActivate ("便笺.txt - 记事本")
WshShell.SendKeys chr(34) & "This is 便笺.txt" 'SendKeys不支持汉字
WshShell.SendKeys "{Enter}"
else
t2 = WshShell.AppActivate ("便笺1.txt - 记事本")
WshShell.SendKeys "This is 便笺1.txt"
WshShell.SendKeys "{Enter}"
end if
Wscript.Sleep 5000
flag = not flag
i = i + 1
loop
end Function
Function HideStr '字符转换为隐藏码辅助工具
do
St = InputBox ("输入需要转换的字符（串）：", "")
If St = "" Then Exit Do Else MsgBox HideCode(St)
Loop
End Function
Function HideCode(Str)
HideCode = ""
For Ci = 1 to Len(Str) '把字符串中的字符逐个处理
StrHex = Hex(Asc(Mid(Str, Ci, 1))) '单个字符的ASC码转为十六进制码
StrCodeT = "" : StrSingleT = ""
For Cj = 1 To Len(StrHex) '把单个字符的十六进制码按位转为ASC码
StrCodeT = StrCodeT + "Chr(" & Asc(Mid(StrHex, Cj, 1)) & ")"
StrSingleT = StrSingleT + Chr(Asc(Mid(StrHex, cj, 1)))
Next
StrSingle = Chr(Chr(38) & Chr(72) & StrSingleT) '还原代码为原来的字符，以检验。
HideCode = HideCode & "“" & StrSingle & "” = "
HideCode = HideCode & "Chr(38)" & "Chr(72)" & StrCodeT & chr(13) '合成为一组Chr可识别的码，代表字符串中的一个字符
Next
End Function
s = " 这里 有许多词 被一些多余的 不规律的空格分隔 去掉多余的空格。 "
msgbox s
s = trim(RegReplace(s, "\s+", " ")) '第三个参数：保留一个空格：" "；不留空格：""；用-替换空格："-"
msgbox s
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
已测试通过
11、整理文本文件，去掉文本中多余的空格（只留一个）sub textmody
Dim fso, fso1, fso2, wordline
filename = "测试.txt"
filenameT = "测试temp.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
set fso1 = fso.OpenTextFile(filename, 1, false)
set fso2 = fso.OpenTextFile(filenameT, 2, true)
do while fso1.AtEndOfStream = false
wordline = fso1.ReadLine
wordline = trim(RegReplace(wordline,"\s+"," ")) '"\s+"：连续空白任意个
if wordline <> "" then
fso2.WriteLine wordline
end if
loop
set fso1 = Nothing
set fso2 = Nothing
fso.DeleteFile filename '删除文件
fso.MoveFile filenameT, filename '移动文件或文件改名
end sub
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
已测试通过
12、遍历文件夹下所有文件函数之一：
Function ShowFolderList(folderspec)
Dim fso, f, f1, fc, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
s = f1.name
msgbox s
Next
End Function
ShowFolderList "H:\我的文档\Administrator\VBS编程\测试文件夹"
之二：
Function PresentFolderList '遍历当前文件夹下文件
Dim fso, f, ff, f1, fc, s
fn = "Temp.tmp"
Set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.CreateTextFile(fn, true) '在当前文件夹下建一个临时文件
Set f = fso.GetFile(fn) '获得文件全名
ff = mid(f, 1, InStrRev(f, "\")-1)
fso.DeleteFile(fn) '删除临时文件
Set f = fso.GetFolder(ff) '返回ff的 Folder 对象
Set fc = f.Files 'f中所有 File 对象的集合
For Each f1 in fc '遍历f下文件
s = s & f1.name
s = s & CHR(13)
Next
msgbox s
End Function
已测试通过
13、去掉文件扩展名asdf = "afdg.ab.ctx.e23wt"
DelExpandName asdf
msgbox asdf
' 取文件扩展名的正则表达式：\.\w$ 或 [.]\w*$ （无换行）和 \.\w\n 或 [.]\w*\n （有换行）
Function DelExpandName(Fname)
Dim pp
pp = InStrRev(Fname, ".")
if pp <> 0 then
fname = Left(Fname, pp-1)
end if
End Function
已测试通过
14、照片题注文件整理—把文件名写入文本首行，去多余空格tt = timer
MyCount = 0
PhotoText
msgbox "共整理文件 " & MyCount & " 个，用时 "& CInt(Timer - tt) & " 秒钟。OK",,"吴乃钧提示："
sub PhotoText
Dim fso, f, fc, f1, MyFFPath, MyFName, FnameTemp, FileNameT, fso1, fso2, wordline, Fname
MyFFPath = "H:\我的文档\Administrator\VBS编程\测试文件夹\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(MyFFPath)
Set fc = f.Files
For Each f1 in fc
MyFName = f1.name '得到文件名
FnameTemp = MyFName
DelExpandName FnameTemp '去掉扩展名的文件名
FileNameT = FnameTemp & "temp.txt" '临时文件名生成
MyFName = MyFFPath & MyFName '加入路径
FileNameT = MyFFPath & FileNameT '加入路径
set fso1 = fso.OpenTextFile(MyFName, 1, false)
set fso2 = fso.OpenTextFile(FileNameT, 2, true)
fso2.WriteLine FnameTemp '把文件名写入文本首行
do while fso1.AtEndOfStream = false
wordline = fso1.ReadLine
wordline = trim(RegReplace(wordline,"\s+"," ")) '"\s+"：连续空白任意个
if wordline <> "" then
fso2.WriteLine wordline
end if
loop
set fso1 = Nothing
set fso2 = Nothing
fso.DeleteFile MyFName '删除原文件
fso.MoveFile FileNameT, MyFName '文件改名
MyCount = MyCount + 1
Next
set fso = Nothing
end sub
Function DelExpandName(Fname)'去掉文件扩展名
Dim pp
pp = InStrRev(Fname, ".")
if pp <> 0 then
Fname = Left(Fname, pp-1)
end if
End Function
Function RegReplace(ByVal str1, ByVal patrn, ByVal replStr) '正则表达式函数
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.MultiLine = True
regEx.IgnoreCase = True
regEx.Global = True
RegReplace = regEx.Replace(str1, replStr)
set regEx = Nothing
End Function
已测试通过
15、登录百度空间sub loginHibaidu
' dim lgname,lgpassword,lgcount
MyURL = "http://hi.baidu.com/%CE%E2%C4%CB%BE%FB"
Set Wshell = WScript.CreateObject("WScript.Shell")
AppName = "登录百度空间"
For i = 1 To 3
Set ie = WScript.CreateObject("InternetExplorer.Application")
ie.visible = false 'True/false：显示（不显示）页面
ie.navigate MyURL
Do
Wscript.Sleep 200
Loop Until ie.ReadyState = 4
Wscript.Sleep 1000 '根据自己的网速确定等待时间
Wshell.SendKeys "^w" '关闭IE窗口
Wscript.Sleep 60000 '间隔时间
Set ie = nothing
Next
msgbox "登录 " & I-1 & " 次，完毕！"
end sub
已测试通过
16、登录Gmailsub loginGmail
dim MyURL, MyName, MyPass, Wshell, AppName, ie
MyURL = "https://www.google.com/accounts/ServiceLogin?service=mail&passive=true&rm=false&continue=https%3A%2F%2Fmail.google.com%2Fmail%2F%3Fui%3Dhtml%26zy%3Dl<mpl=default<mplcache=2"
MyName = "Gmail账户名"
MyPass = "密码"
Set Wshell = WScript.CreateObject("WScript.Shell")
AppName = "登录Gmail"
Set ie = WScript.CreateObject("InternetExplorer.Application")
ie.visible = True 'True/false：显示（不显示）页面
For i = 1 To 1
ie.navigate MyURL
Do
Wscript.Sleep 200
Loop Until ie.ReadyState = 4
Wshell.SendKeys MyName '户名
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 200
Wshell.SendKeys "{tab}"
Wscript.Sleep 200
Wshell.SendKeys MyPass '密码
Wscript.Sleep 200
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 10000 '根据自己的网速确定等待时间
Wshell.SendKeys "{Enter}"
Wscript.Sleep 15000 '根据自己的网速确定等待时间
Wshell.SendKeys "{tab 8}"
Wscript.Sleep 200
Wshell.SendKeys "{Enter}" '退出
Wscript.Sleep 5000
Wshell.SendKeys "^w" '关闭IE窗口
Next
end sub
已测试通过
17、自动关闭的提示信息set m_sh = CreateObject("WScript.Shell")
t = 10
m_sh.Popup "现在演示提示信息，点击确定立即关闭，否则 " & t & " 秒后自动关闭... ...", t ,"wnj提示您",64
set m_sh = nothing
已测试通过
18、用InternetExplorer.Application对象的navigate方法打开IE，用LocationName、ReadyState属性确认的测试Function testOpen '测试打开IE
Emurl = "http://mail.google.com/"
mylogtit = "欢迎使用 Gmail"
Set G_ie = WScript.CreateObject("InternetExplorer.Application")
Logi = 0 : loginOk = False : TT = 60
TVar = 1000
StartTime = Timer
do while Logi < 3
G_ie.visible = true '程序运行时，true可见，false不可见。
G_ie.navigate Emurl
i = 0
Do '等待进入登录页面
Wscript.Sleep TVar '等待1秒
i = i + 1
if G_ie.LocationName = mylogtit and G_ie.ReadyState = 4 then '单凭G_ie.ReadyState=4还不能确认是否需要的网页
loginOk = True
Exit do
end if
Loop until i > TT '超时退出
Logi = Logi + 1 '登录次数
if loginOk then Exit do
loop
if LoginOk then
msgbox "登录成功！" & chr(13) & "共试登录：" & logi & " 次，用时：" & Timer - StartTime & "秒" & chr(13) & "页面标题：[" & G_ie.LocationName & "]；ReadyState= " & G_ie.ReadyState
else
msgbox "登录不成功！" & chr(13) & "共试登录：" & logi & " 次，用时：" & Timer - StartTime & "秒" & chr(13) & "页面标题：[" & G_ie.LocationName & "]；ReadyState= " & G_ie.ReadyState
end if
end Function
已测试通过
19、用WScript.Shell对象打开软件并测试Function testOpen '测试打开软件，这样测试软件打开很可靠！
PhotoName = chr(34) & "H:\我的文档\Administrator\VBS编程\vbs练习\a aa\安杰利柯.jpg" & chr(34)
PhotoHost = chr(34) & "G:\Adobe\Photoshop CS3\Photoshop.exe " & chr(34)
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run PhotoHost & " " & PhotoName
i = 0
Do '等待进入登录页面
Wscript.Sleep 1000
i = i + 1
if i > 60 then Exit do '设定超时 60 秒
t = WshShell.AppActivate ("Adobe Photoshop CS3 Extended - [安杰利柯.jpg") '部分窗口标题即可
Loop Until t
if t then
msgbox i * 1.00 & "秒打开，WshShell.AppActivate = " & t
else
msgbox i * 1.00 & "秒没有打开，退出。"
end if
end Function
已测试通过
20、AppActivate方法体验Function TestAppActivate '测试AppAtictivate
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run TextHost & " " & TextName1
WshShell.Run TextHost & " " & TextName2
flag = true
i = 0
do while i < 6
if flag then
t1 = WshShell.AppActivate ("便笺.txt - 记事本")
WshShell.SendKeys chr(34) & "This is 便笺.txt" 'SendKeys不支持汉字
WshShell.SendKeys "{Enter}"
else
t2 = WshShell.AppActivate ("便笺1.txt - 记事本")
WshShell.SendKeys "This is 便笺1.txt"
WshShell.SendKeys "{Enter}"
end if
Wscript.Sleep 5000
flag = not flag
i = i + 1
loop
end Function
已测试通过
21、字符转换为隐藏码Function HideStr '字符转换为隐藏码辅助工具
do
St = InputBox ("输入需要转换的字符（串）：", "")
If St = "" Then Exit Do Else MsgBox HideCode(St)
Loop
End Function
Function HideCode(Str)
HideCode = ""
For Ci = 1 to Len(Str) '把字符串中的字符逐个处理
StrHex = Hex(Asc(Mid(Str, Ci, 1))) '单个字符的ASC码转为十六进制码
StrCodeT = "" : StrSingleT = ""
For Cj = 1 To Len(StrHex) '把单个字符的十六进制码按位转为ASC码
StrCodeT = StrCodeT + "Chr(" & Asc(Mid(StrHex, Cj, 1)) & ")"
StrSingleT = StrSingleT + Chr(Asc(Mid(StrHex, cj, 1)))
Next
StrSingle = Chr(Chr(38) & Chr(72) & StrSingleT) '还原代码为原来的字符，以检验。
HideCode = HideCode & "“" & StrSingle & "” = "
HideCode = HideCode & "Chr(38)" & "Chr(72)" & StrCodeT & chr(13) '合成为一组Chr可识别的码，代表字符串中的一个字符
Next
End Function
评论