vbs编程实例

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

已测试通过

3、登录sina邮箱

Set Wshell=WScript.CreateObject("WScript.Shell")

AppName="sina邮箱"

Set ie7=WScript.CreateObject("InternetExplorer.Application")

ie7.visible=True

ie7.navigate "https://www.360docs.net/doc/b19389401.html,/"

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 ' 根据自己的网速确定等待时间

已测试通过

4、自动登录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 "https://www.360docs.net/doc/b19389401.html,"

While ie.Busy

Wscript.Sleep 100

wend

https://www.360docs.net/doc/b19389401.html,ername.value="邮箱名"

ie.Document.login163.password.value="邮箱登录密码"

WShell.SendKeys "~" ' 回车

Wscript.Sleep 10000 ' 根据自己的网速确定等待时间

Wshell.SendKeys "^W" ' 关闭IE窗口。注：这句没起作用？next

已测试通过

5、自动登录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 "https://www.360docs.net/doc/b19389401.html,"

While ie.Busy

Wscript.Sleep 100

wend

' Do

' Wscript.Sleep 200

' Loop Until ie.ReadyState=4

https://www.360docs.net/doc/b19389401.html,er.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 "https://www.360docs.net/doc/b19389401.html,/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 "https://www.360docs.net/doc/b19389401.html,/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 "https://www.360docs.net/doc/b19389401.html," '设置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 = "测试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 = https://www.360docs.net/doc/b19389401.html,

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 & https://www.360docs.net/doc/b19389401.html,

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 = https://www.360docs.net/doc/b19389401.html, '得到文件名

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 = "https://www.360docs.net/doc/b19389401.html,/%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 = "https://https://www.360docs.net/doc/b19389401.html,/accounts/ServiceLogin?service=mail&passive=true&rm=false&continu e=https%3A%2F%https://www.360docs.net/doc/b19389401.html,%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 = "https://www.360docs.net/doc/b19389401.html,/"

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 TV ar '等待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