Board logo

标题: [原创] vbs+wget 实现网站图片下载 by yu2n [打印本页]
作者: yu2n    时间: 2014-7-1 04:42     标题: vbs+wget 实现网站图片下载 by yu2n

本帖最后由 yu2n 于 2014-7-1 04:52 编辑

vbs 函数过程：
1. 调用wget: 下载网站所有页面到本脚本目录 ……
2. 扫描本脚本目录中所有文件 ……
3. 读取本脚本目录中的所有网页，匹配图片 URL 地址 ……
4. 保存所有图片 URL 地址到 url-img.txt 文件 ……
5. 调用wget: 下载 url-img.txt 指定的图片到本脚本 img 目录 ……
  1. ' wget_img.vbs

  2. Call Main()

  3. Sub Main()

  4. 

  5.   ' CMD 模式

  6.   If Not (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then

  7.     CreateObject("WScript.Shell").Run "cscript.exe //nologo """ & WScript.ScriptFullName & """", 1, False

  8.     WScript.Quit(1)

  9.   End If

  10.   

  11.   Dim wso, strMeDir

  12.   Set wso = WScript.CreateObject("WScript.Shell")

  13.   strMeDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")-1)

  14.   ' 启动 wget下载网站所有页面到本脚本目录的 720.hao2046.net 文件夹

  15.   WScript.Echo "1. 启动 wget下载网站所有页面到本脚本目录的 720.hao2046.net 文件夹 ……"

  16.   wso.Run "wget -r -p -k -c -x -A=jpg,htm,html 720.hao2046.net -P """ & strMeDir & """", 1, True

  17. 

  18.   ' 扫描 720.hao2046.net 文件夹中所有文件

  19.   WScript.Echo "2. 扫描 720.hao2046.net 文件夹中所有文件 ……"

  20.   Dim strFolderspec, strHTML, strURL

  21.   Dim arr() : ReDim Preserve arr(0)

  22.   strFolderspec = strMeDir & "\720.hao2046.net"

  23.   Call ScanFolder(arr, strFolderspec)

  24.   

  25.   ' 建立正则表达式。

  26.   Dim regEx

  27.   Set regEx = CreateObject("VBScript.RegExp")     ' 建立正则表达式。

  28.   regEx.IgnoreCase = True     ' 设置是否区分大小写。

  29.   regEx.Global = True         ' 设置全局替换。

  30.   regEx.MultiLine = True      ' 设置多行匹配模式

  31.   

  32.   ' 查找所有文件

  33.   WScript.Echo "3. 读取 720.hao2046.net 文件夹中的所有网页，匹配图片 URL 地址 ……"

  34.   For i = 0 To UBound(arr)

  35.       If LCase(Right(arr(i),5)) = ".html" Or LCase(Right(arr(i),4)) = ".htm" Then

  36.           ' 读取文件，匹配图片 URL 地址

  37.           strHTML = ReadPfile(arr(i), "gb2312")

  38.           regEx.Pattern = "src=['""]http://\S+\.jpg['""]"

  39.           Set Matches = regEx.Execute(strHTML)      ' 执行搜索。

  40.           For Each Match in Matches  ' 遍历匹配集合。

  41.               If Not Match.Value = "" Then

  42.                   regEx.Pattern = "(src=['""])*(['""])*"

  43.                   strURL = strURL & regEx.Replace(Match.Value, "") & vbCrLf

  44.               End If

  45.           Next

  46.       End If

  47.   Next

  48.   

  49.   ' 保存所有图片 URL 地址

  50.   WScript.Echo "4. 保存所有图片 URL 地址到 url-img.txt 文件 ……"

  51.   Call SavePfile(strMeDir & "\url-img.txt", "utf-8", strURL) 

  52.   

  53.   ' 启动 wget 下载图片到本脚本 img 目录

  54.   WScript.Echo "5. 启动 wget 下载 url-img.txt 指定的图片到本脚本 img 目录 ……"

  55.   wso.Run "wget -c -x -t 5 -i """ & strMeDir & "\url-img.txt"" -P """ & strMeDir & "\img""", 1, True

  56.   

  57.   Msgbox "完成！"

  58. End Sub

  59. 

  60. '===========================================================================================

  61. '按编码读取txt文件内容

  62. Function ReadPfile(ByVal FileName, ByVal FileCode)

  63.     Dim objStream

  64.     Set objStream = CreateObject("ADODB.Stream")

  65.     '

  66.     With objStream

  67.         .Type = 2

  68.         .Mode = 3

  69.         .open

  70.         .Charset = FileCode      '不同编码时自己换,Chinese (Simplified) (GB2312),中文 GBK ,繁体中文 Big5 ,日文 EUC-JP ,韩文 EUC-KR,charset=UTF-8(国际化编码),ANSI,Unicode,unicode big endian

  71.         .LoadFromFile FileName

  72.          ReadPfile = .ReadText

  73.         .Close

  74.     End With

  75.     Set objStream = Nothing

  76. End Function

  77. 

  78. '===========================================================================================

  79. '保存文件为unicode格式文本

  80. Function SavePfile(ByVal FileName, ByVal FileCode, ByVal TextString)

  81.     Dim objStream

  82.     Set objStream = CreateObject("ADODB.Stream")

  83.     With objStream

  84.         .Type = 2

  85.         .Mode = 3

  86.         .Charset = FileCode      '不同编码时自己换,Chinese (Simplified) (GB2312),中文 GBK ,繁体中文 Big5 ,日文 EUC-JP ,韩文 EUC-KR,charset=UTF-8(国际化编码),ANSI,Unicode,unicode big endian

  87.         .open

  88.         .WriteText TextString

  89.         .SaveToFile FileName, 2

  90.         .Close

  91.     End With

  92.     Set objStream = Nothing

  93. End Function

  94. 

  95. '    Dim arr() : ReDim Preserve arr(0)

  96. '    Call ScanFolder(arr, "V:\")

  97. Sub ScanFolder(ByRef arr, ByVal strFolderspec)

  98.     On Error Resume  Next

  99.     Dim fso, objFolder

  100.     Set fso = Createobject("Scripting.FileSystemObject")

  101.     Set objFolder = fso.getfolder(strFolderspec)

  102.     ReDim Preserve arr(UBound(arr)+1)

  103.     arr(UBound(arr)) = strFolderspec & "\"

  104.     For Each subFile In objFolder.files

  105.         ReDim Preserve arr(UBound(arr)+1)

  106.         arr(UBound(arr)) = subFile.path

  107.     Next

  108.     For Each subFolder In objFolder.subfolders

  109.         ScanFolder arr, subFolder.path

  110.     Next

  111.     Set fso = NoThing

  112.     Set objFolder = NoThing

  113. End Sub  
复制代码
附网页文件查找字符串代码(findstr_html.vbs)：
  1. ' findstr_html.vbs

  2. Call Main()

  3. Sub Main()

  4. 

  5.   ' CMD 模式

  6.   If Not (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then

  7.     CreateObject("WScript.Shell").Run "cscript.exe //nologo """ & WScript.ScriptFullName & """", 1, False

  8.     WScript.Quit(1)

  9.   End If

  10. 

  11.   Dim strMeDir

  12.   strMeDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")-1)

  13.   Dim regEx, strHTML, strURL

  14.   

  15.   ' 扫描文件夹

  16.   Dim arr() : ReDim Preserve arr(0)

  17.   Call ScanFolder(arr, strMeDir & "\720.hao2046.net")

  18.   If UBound(arr) = 0 Then

  19.     WScript.Echo strMeDir & "\720.hao2046.net" & ", Not Found!"

  20.     Exit Sub

  21.   End If

  22. 

  23.   ' 建立正则表达式。

  24.   Set regEx = CreateObject("VBScript.RegExp")     ' 建立正则表达式。

  25.   regEx.IgnoreCase = True     ' 设置是否区分大小写。

  26.   regEx.Global = True         ' 设置全局替换。

  27.   regEx.MultiLine = True      ' 设置多行匹配模式

  28.   

  29.   

  30.   Do

  31.     strPattern = InputBox("请输入要匹配的正则表达式：","查找所有网页文件","123456")

  32.     strInfo = strPattern & vbCrLf & "Not Found!"

  33.     For i = 0 To UBound(arr)

  34.       If LCase(Right(arr(i),5)) = ".html" Or LCase(Right(arr(i),4)) = ".htm" Then

  35.         'WScript.Echo arr(i)

  36.         strHTML = ReadPfile(arr(i), "gb2312")

  37.         If InStr(strHTML, strPattern)>0 Then

  38.           strInfo = strPattern & vbCrLf & arr(i) & vbCrLf

  39.           Exit For

  40.         Else

  41.           'regEx.Pattern = "src=['""]http://\S+\.jpg['""]"

  42.           regEx.Pattern = strPattern

  43.           Set Matches = regEx.Execute(strHTML)      ' 执行搜索。

  44.           For Each Match in Matches  ' 遍历匹配集合。

  45.             If Not Match.Value = "" Then

  46.               'regEx.Pattern = "(src=['""])*(['""])*"

  47.               'strURL = strURL & regEx.Replace(Match.Value, "") & vbCrLf

  48.               strInfo = strPattern & vbCrLf & arr(i) & vbCrLf

  49.               Exit For

  50.             End If

  51.           Next

  52.         End If

  53.       End If

  54.     Next

  55.     WScript.Echo strInfo

  56.     Loop

  57. End Sub

  58. 

  59. 

  60. '===========================================================================================

  61. '按编码读取txt文件内容

  62. Function ReadPfile(ByVal FileName, ByVal FileCode)

  63.     Dim objStream

  64.     Set objStream = CreateObject("ADODB.Stream")

  65.     '

  66.     With objStream

  67.         .Type = 2

  68.         .Mode = 3

  69.         .open

  70.         .Charset = FileCode      '不同编码时自己换,Chinese (Simplified) (GB2312),中文 GBK ,繁体中文 Big5 ,日文 EUC-JP ,韩文 EUC-KR,charset=UTF-8(国际化编码),ANSI,Unicode,unicode big endian

  71.         .LoadFromFile FileName

  72.          ReadPfile = .ReadText

  73.         .Close

  74.     End With

  75.     Set objStream = Nothing

  76. End Function

  77. 

  78. '    Dim arr() : ReDim Preserve arr(0)

  79. '    Call ScanFolder(arr, "V:\")

  80. Sub ScanFolder(ByRef arr, ByVal strFolderspec)

  81.     On Error Resume  Next

  82.     Dim fso, objFolder

  83.     Set fso = Createobject("Scripting.FileSystemObject")

  84.     Set objFolder = fso.getfolder(strFolderspec)

  85.     ReDim Preserve arr(UBound(arr)+1)

  86.     arr(UBound(arr)) = strFolderspec & "\"

  87.     For Each subFile In objFolder.files

  88.         ReDim Preserve arr(UBound(arr)+1)

  89.         arr(UBound(arr)) = subFile.path

  90.     Next

  91.     For Each subFolder In objFolder.subfolders

  92.         ScanFolder arr, subFolder.path

  93.     Next

  94.     Set fso = NoThing

  95.     Set objFolder = NoThing

  96. End Sub  
复制代码
提示：
1. 警告：请不要直接运行代码，这里的示范网址可能无法访问、或缺乏安全性，请改为其他网址再使用。
2. 请将 wget.exe 放置于脚本同一目录下，然后执行。文件结构如下：
  ..\wget.exe
  ..\wget_img.vbs
  ..\findstr_html.vbs
作者: zhanglei1371    时间: 2014-7-1 12:05

感谢分享，很强大
作者: wenlishasha    时间: 2014-7-1 18:57

O(∩_∩)O谢谢楼主，高手！！！



欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2