【分享】vba小应用: 一个简单的批量网页链接下载器

[Fpc]

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

[springbr]

感谢楼主分享代码, 也许用wget来下载也很方便.

[cckld]

给个例子 用在哪？

[lihuanqing]

收藏，抽时间试一试