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

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

下面是代码分享

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

Dim oHtml As Object

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

Dim sUrl As String

'指定要抓取的网站

sUrl = ";

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

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