页面

2009年3月27日

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、计算程序运行秒数
StartTime = Timer
... ...
msgbox "运行程序用时:" & int(Timer - S
tartTime) & " 秒。"

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 ' 根据自己的网速确定等待时间
已测试通过
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
已测试通过
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
已测试通过
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
已测试通过
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、登录Gmail
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&ltmpl=default&ltmplcache=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

没有评论: