请前辈们编写一个网抓的宏

13907933959

把下面这个网址上的“中医古籍”（蓝色字链接的）每个依次点开，每本古籍依次复制里面的每页正文一起粘贴到Word文档上单独成一个文档。
http://www.tcm100.com/zhongyiguji.aspx
恳求前辈们帮忙！在下拜谢！

duquancai

Sub shishi()
    Dim strText$, n%
    URL = "http://www.tcm100.com/"
    Application.ScreenUpdating = True
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL & "zhongyiguji.aspx", False
        .send
        strText = .responseText
        For i = 1 To 1 '第一层抓取数量自己设置，别抓多了，多了会卡死，网上最多好像是740条左右
            For j = 3 To 15 '第二层抓取自己设置，每次的初始值和结束值无规律，不好吧，这个参数只是抓取第一层下面的所有。
                .Open "GET", URL & Split(Split(strText, "<a target='_blank' href='")(i), "index.htm'>")(0) & "zzbook" & j & ".htm", False
                .send
                strText = strText + .responseText
            Next
        Next
    End With
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "<td[\s\S]*?<div\s*class='title'[\s\S]*?>([\s\S]+?)</div>[\s\S]*?<div\s*class='title'>([\s\S]+?)</div>[\s\S]*?<div\s* class='content'>([\s\S]+?)</div>[\s\S]*?</td>"
        For Each RegMatch In .Execute(strText)
            t1 = RegMatch.SubMatches(0)
            t2 = RegMatch.SubMatches(1)
            t3 = RegMatch.SubMatches(2)
            t = t & t1 & Chr(13) & t2 & Chr(13) & t3 & Chr(13)
        Next
        .Pattern = "(?:<a\s*href=[\s\S]+?>)|</a>": t = .Replace(t, "")
        .Pattern = "(?!<br>)(?:&nbsp;)+": t = .Replace(t, "  ")
        .Pattern = "<br>\s+": t = .Replace(t, Chr(13))
    End With
    Application.ScreenUpdating = True
    Documents.Add.Content.Text = t
End Sub

duquancai

For i = 1 To 1 '第一层抓取数量自己设置，别抓多了，多了会卡死，网上最多好像是740条左右
            For j = 3 To 15 '第二层抓取自己设置，每次的初始值和结束值无规律，不好办（目前我还不知道j值的初始值和结束值应该怎么判断？），这个参数只是抓取第一层下面的所有。
                .Open "GET", URL & Split(Split(strText, "<a target='_blank' href='")(i), "index.htm'>")(0) & "zzbook" & j & ".htm", False
                .send
                strText = strText + .responseText
            Next
Next比如第二层参数下：
for i=2 to 2
     for  j=6 to 86
     next
next

13907933959

duquancai 发表于 2016-7-24 18:45
For i = 1 To 1 '第一层抓取数量自己设置，别抓多了，多了会卡死，网上最多好像是740条左右
             ...

前辈好！
感谢前辈出手相助！
由于水平还处在只会用的阶段，您给代码不知如何才能运行，求前辈能给一个全代码。谢谢！

duquancai

13907933959 发表于 2016-7-24 19:19
前辈好！
感谢前辈出手相助！
由于水平还处在只会用的阶段，您给代码不知如何才能运行，求前辈能给一个 ...

请耐心等待，代码在2楼的，版主正在审核！

duquancai

13907933959 发表于 2016-7-24 19:19
前辈好！
感谢前辈出手相助！
由于水平还处在只会用的阶段，您给代码不知如何才能运行，求前辈能给一个 ...

建议你一本书抓一次，一本书保存为一个word文件。
比如：第一本书，参数这样：for i=1 to 1    for j=3 to 15   这样抓一次保存为一个word文件。（我测试270页左右）
         第二本书，参数这样：for i=2 to 2    for j=6 to 86   这样抓一次又保存为一个word文件。（没测试，不敢测试，估计得上千页）
         因此建议手动修改这两个（i，j）参数。
         若果你想一次性都抓下来，这个数据量大的吓死人！估计是抓不下来，因为word早就崩溃了，估计电脑也罢工了，最后造成你自己也崩溃了！呵呵！！！

13907933959

duquancai 发表于 2016-7-24 18:43
Sub shishi()
    Dim strText$, n%
    URL = "http://www.tcm100.com/"

前辈好！

感谢前辈！可不可一次抓取5本或10本？如可该如何设置？还有就是如前面的5本如以抓取了，又如何让它从6本开始抓取下一个5本？

For i = 1 To 1 '第一层抓取数量自己设置， For j = 3 To 15 '第二层抓取自己设置。

这个第一层和第二层的参数如一本一本抓取，您以给了第一本、第二本的参数，第三本、第四本、……再后面参数怎样才能知道，要具体怎样设置还请前辈教我！谢谢！

13907933959

duquancai 发表于 2016-7-25 00:59
建议你一本书抓一次，一本书保存为一个word文件。
比如：第一本书，参数这样：for i=1 to 1    for j=3  ...

前辈好！
回复正在审核中…。

kqbt

duquancai 发表于 2016-7-24 18:43
Sub shishi()
    Dim strText$, n%
    URL = "http://www.tcm100.com/"

正则很强大！

duquancai

13907933959 发表于 2016-7-25 07:29
前辈好！感谢前辈！可不可一次抓取5本或10本？如可该如何设置？还有就是如前面的5本如以抓取了，又如何让它 ...

下面代码是网抓整个网站的内容，请一定要注意看代码中的注释，还是那个话：建议一本抓一个word文档，你实在要5本一抓也行。
比如：For i = 1 To UBound(arr)    改为：For i = 1 To 1  抓第一本  For i = 2 To 2  抓第三本 For i = 3 To 3  抓第三本；For i = 1 To 5 抓第一本到第五本 For i = 1 To 10  抓第一本到第10本。

1. Sub shishi()
   
2.     Dim strText$, i&, j&, arr, arr1
   
3.     URL = "http://www.tcm100.com/"
   
4.     Application.ScreenUpdating = True
   
5.     With CreateObject("msxml2.xmlhttp")
   
6.         .Open "GET", URL & "zhongyiguji.aspx", False
   
7.         .send
   
8.         strText = .responseText
   
9.         arr = Split(strText, "<a target='_blank' href='") '表示有多少本书（本网站共有“762本书”)
   
10.         For i = 1 To UBound(arr) '建议每一次就设置“1”就是抓一本书，设置“2”就是抓第二本书，一定要改，否则把整个网站都抓下来了！呵呵呵！！！
    
11.             .Open "GET", URL & Split(Split(strText, "<a target='_blank' href='")(i), "'>")(0), False
    
12.             .send
    
13.             strText = .responseText
    
14.             arr1 = Split(strText, "<a target='_blank' href='")
    
15.             For j = 1 To UBound(arr1)  '这个循环表示每一本书中的数目数量
    
16.                 .Open "GET", Split(Split(strText, "<a target='_blank' href='")(j), "'>")(0), False
    
17.                 .send
    
18.                 strText = strText & .responseText '表示包含所有书的所有页面内容的超文本
    
19.             Next
    
20.         Next
    
21. '        Debug.Print strText
    
22.     End With
    
23.     With CreateObject("VBScript.Regexp")
    
24.         .Global = True
    
25.         .Pattern = "<td[\s\S]*?<div\s*class='title'[\s\S]*?>([\s\S]+?)<[\s\S]*?<div\s* class='content'>([\s\S]+?)</div>[\s\S]*?</td>"
    
26.         For Each RegMatch In .Execute(strText)
    
27.             t1 = RegMatch.SubMatches(0)
    
28.             t2 = RegMatch.SubMatches(1)
    
29.             t = t & t1 & Chr(13) & t2 & Chr(13)
    
30.         Next
    
31.         .Pattern = "(?:<a\s*href=[\s\S]+?>)|</a>": t = .Replace(t, "")
    
32.         .Pattern = "(?!<br>)(?:&nbsp;)+": t = .Replace(t, "  ")
    
33.         .Pattern = "<br>\s+": t = .Replace(t, Chr(13))
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36.     Documents.Add.Content.Text = t
    
37. End Sub

复制代码