VBA代码、网页数据采集、爬取文章

应粉丝要求做一篇爬取网页上的文章。

实现功能：爬取网站上的一篇文章并保存到记事本上。

下面是代码分享

Sub 采集网页上的文章保存到记事本()

Dim oHtml As Object

Set oHtml = VBA.CreateObject('WinHttp.WinHttpRequest.5.1') '创建http对象

Dim sUrl As String

'指定要抓取的网站

sUrl = 'http://meiwenjx.com/article/143357.html'

With oHtml

.Open 'GET', sUrl, False '向服务器发送指定链接地址

.send '发送

'获取返回的字节数组

bResult = .ResponseBody

'按照指定的字符编码显示

sResult = bytestobstr(bResult, 'GB2312')

shu = Split(sResult, '<p>') '拆分返回来字符串赋给数组

For wun = 1 To UBound(shu) - 1 '循环数组最大下标

js = js & Chr(13) & Replace(shu(wun), '</p>', '') '把数组里的内容写变量

Next wun

js2 = Split(shu(UBound(shu)), '</p>') '按指定字符拆分内容并赋给变量

Open ThisWorkbook.Path & '\网文采集.txt' For Output As #1 '打开当前工作簿下的记事本，如果没有就创建

Print #1, js & js2(0) '把内容写进记事本里

Close #1 '关闭记事本

End With

Set oHtml = Nothing '清空对象

MsgBox '网文采集完成'

End Sub

'下面是采集用到的Bstr编码转换函数

Function bytestobstr(strbody, codebase)

Dim objstream

On Error Resume Next

Set objstream = CreateObject('adodb.stream')

With objstream

.Type = 1

.Mode = 3

.Open

.write strbody

.Position = 0

.Type = 2

.Charset = codebase

bytestobstr = .readtext

End With

objstream.Close

Set objstream = Nothing

If Err.Number <> 0 Then bytestobstr = ''

On Error GoTo 0

End Function

如果想多学习一点可以去我公众号看，上面写得详细一点