. : : ClassiClub ForuM : : .

会员中心 论坛帮助 日历事件 标记论坛已读
返回   精品技术论坛 » 技术论坛 » 『软件使用』 » 专题:办公邮件

『软件使用』: 电脑软件推荐, 电脑软件使用, 经验分享



发表新主题 关闭主题
 
主题工具
Fpc
 
Fpc 的头像
热心会员
 
资 料:
注册日期: Sep 2001
帖子: 2,394 声望值: 6
精华: 1,解答: 1
#1 旧 2010-01-08, 13:49:29 Icon7 【分享】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
 
springbr 的头像
初级会员
 
资 料:
注册日期: Jun 2002
帖子: 239 声望值: 3
精华: 0
#2 旧 2010-01-09, 13:42:11 默认
springbr 当前离线  

感谢楼主分享代码, 也许用wget来下载也很方便.
cckld
 
cckld 的头像
超级会员
 
资 料:
注册日期: Dec 2000
帖子: 2,039 声望值: 3
精华: 0,解答: 2
#3 旧 2010-01-09, 16:51:48 默认
cckld 当前离线  

给个例子 用在哪?
lihuanqing
 
lihuanqing 的头像
热心会员
 
资 料:
注册日期: Mar 2001
帖子: 2,313 声望值: 4
精华: 2,解答: 4
#4 旧 2010-01-09, 21:10:49 默认
lihuanqing 当前离线  

收藏,抽时间试一试
发表新主题 关闭主题

主题工具

论坛规则  发帖规则
不可以发表主题
不可以回复帖子
不可以上传附件
不可以编辑自己的帖子
论坛启用 vB 代码
版面启用 表情符号
版面启用 [IMG] 代码
版面禁用 HTML 代码


所有时间均为北京时间, 现在的时间是 08:14:47.

本论坛带宽由迅通网络提供
SSL证书由TrustAsia提供

Copyright © 2000 - 2019 ClassiClub Forum All Rights Reserved.
粤ICP备09123456号