![]() 热心会员
|
vba小应用: 一个简单的批量网页链接下载器 上网的电脑因种种原因不能用flashget等批量下载软件,想下载多个页面大概几千个小文件,一个一个另存为要出人命的,好在有vba。经过漫长的搜索、修改,终于搞成了。帖出来共享一下。 以下是代码,帖到excel vba编辑器中即可用(有些内容已隐去,请自己修改): 代码:
'本批量网页链接下载器代码大部分来自网上,简单修改拼装了一下 '如误用或引起不良后果由使用者自己负责 ' '声明 Private Declare Function timeGetTime Lib "winmm.dll" () As Long '延时函数,很安全,程序不会失去响应 Public Sub Delay(ByVal num As Integer) Dim t As Long t = timeGetTime Do Until timeGetTime - t >= num * 1000 DoEvents Loop End Sub Sub aaa() '用于下载的涵数,随便起个名字 Dim s, ss(), szFileName(), k, r%, i&, j& Dim tomURL, searchStr, szPath tomURL = "http://*********.com/" '这个主要是用于拼链接地址之用 searchStr = "../" '网页上用到的相对地址 szPath = "D:\Documents_and_Settings\*******\My Documents\abcabc\" '本地保存地址 On Error Resume Next Set ie = CreateObject("Msxml2.XMLHTTP") j = 0 For r = 10 To 25 '这里控制你要下载几个网页中的链接 Delay 5 '延时5秒,作人要厚道 Debug.Print "当前页面" & r '运行时简单监控一下 ie.Open "GET", "http://************.com/***********" & r & ".htm", False ie.Send Do Until ie.ReadyState = 4 DoEvents Loop '等待网页处理完成再运行下面的代码 s = Split(ie.responseText, """") '把源文件中的引号替换成换行,以便提取链接 For i = 0 To UBound(s) If s(i) Like "*XXXX*" Then If InStr(s(i), "XXX") Then '这里两行查找含有待下载文件类型地址的链接 j = j + 1 ReDim Preserve ss(1 To j) ReDim Preserve szFileName(1 To j) ss(j) = tomURL & Mid(s(i), 4) '把含有地址的链接址传递给数组ss szFileName(j) = Mid(s(i), 16) '生成本地保存的文件名 'Debug.Print ss(j) 'Debug.Print szFileName(j) End If End If Next Next For i = 1 To UBound(ss) ie.Open "GET", ss(i), False ie.Send Do Until ie.ReadyState = 4 DoEvents Loop With CreateObject("ADODB.Stream") .Type = 1 .Open .write ie.Responsebody .savetofile szPath & szFileName(i), 2 '保存文件 .Close End With Delay 5 '延时5秒,作人要厚道 Next MsgBox "all done." '结束时的提示 End Sub |
||
![]() 初级会员
|
感谢楼主分享代码, 也许用wget来下载也很方便.
|
||
![]() 超级会员
|
给个例子 用在哪?
|
||
![]() 热心会员
|
收藏,抽时间试一试
|
||