百度空间 | 百度首页 | 登录 吴乃钧 主页博客相册|个人档案 |好友 查看文章
vbs编程实例2007-09-19 16:411、快速显示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
已测试通过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 "mail.sina/"
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 "mail.163"
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
已测试通过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 "mail.126"
While ie.Busy
Wscript.Sleep 100
wend
' Do
' Wscript.Sleep 200
' Loop Until ie.ReadyState=4
ie.Document.form.u
ser.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 "www.mail-magic/i?forum=&inmembername=用户名&inpassword=密码"
Do
Wscript.Sleep 200
Loop Until ie.ReadyState=4
Wshell.SendKeys "{tab 22}" '到“登录”键
Wshell.SendKeys "{Enter}" '回车
Wscript.Sleep 8000 '根据自己的网速确定等待时间
ie.navigate "www.mail-magic/i?action=logout" '退出
Wscript.Sleep 200
Wshell.SendKeys "^w" '关闭IE窗口
Next
end sub
已成功登录及退出8、VBS对网页的操作
创建internetexplorer.application对象如下
Set ie=WScript.CreateObject("internetexplorer.application")
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" '设置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
已测试通过11、整理文本文件，去掉文本中多余的空格（只留一个）
sub textmody
Dim fso, fso1, fso2, wordline
filename = "测试.txt"
filenameT = "测试"
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
vbs小程序代码大全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 = "p"
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 = "23wt"
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 & "" '临时文件名生成
MyFName = MyFFPath & MyFName '加入路径
FileNameT = MyFF
Path & 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 = "hi.baidu/%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、登录Gmail
sub loginGmail
dim MyURL, MyName, MyPass, Wshell, AppName, ie
MyURL = "le/accounts/ServiceLogin?service=mail&passive=true&rm=false&continue=https%3A%le%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 '根据自己的
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论