自建公式，VBA在Excel中轻松获取反义词

---

前言

小学语文中，近义词、反义词是必考内容之一。家长不能随时辅导怎么办？有VBA，一键爬取网络数据。

---

一、爬取网站数据

本次使用的网站网址为：https://www.putongtianxia.com/，网站截图如下：

该网站有个小缺点，有的反义词只有一个，比如“高”，反义词可以是“低”，也可以是“矮”，但返回数据只有“低”。

代码也有个缺点，只设置获取一个反义词，有兴趣的童鞋可以对代码稍作修改。

二、代码

1.创建数据发送及返回方法

Function sendAndget1(url As String, resultA As String)  Dim re As ObjectDim rl As ObjectDim st As ObjectOn Error Resume NextSet xmlhttp = CreateObject("msxml2.xmlhttp")xmlhttp.Open "GET", url, Falsexmlhttp.sendIf xmlhttp.READYSTATE = 4 Thena = StrConv(xmlhttp.RESPONSEBODY, vbUnicode)End IfSet re = CreateObject("vbscript.RegExp")With re.IgnoreCase = True.Global = True.Pattern = "utf-8|gb2312|gbk"Set rl = .Execute(a)End WithCh = rl.Item(0)Set st = CreateObject("adodb.stream")With st.Mode = 3.Type = 1.Open.write xmlhttp.RESPONSEBODY.Position = 0.Type = 2.Charset = ChresultA = .readtext.CloseEnd With
End Function

2.汉字转UTF8编码

Function strToUtf8(str As String) As String     '汉字转UTF8编码Dim wch  As StringDim uch As StringDim szRet As StringDim x As LongDim inputLen As LongDim nAsc  As LongDim nAsc2 As LongDim nAsc3 As LongIf str = "" ThenstrToUtf8 = strExit FunctionEnd IfinputLen = Len(str)For x = 1 To inputLenwch = Mid(str, x, 1)nAsc = AscW(wch)'对于<0的编码　其需要加上65536If nAsc < 0 Then nAsc = nAsc + 65536'对于<128位的ASCII的编码则无需更改If (nAsc And &HFF80) = 0 ThenszRet = szRet & wchElseIf (nAsc And &HF000) = 0 Thenuch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)szRet = szRet & uchElseuch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _Hex(nAsc And &H3F Or &H80)szRet = szRet & uchEnd IfEnd IfNextstrToUtf8 = szRet
End Function

2.获取反义词

Function fanyici(str1 As String) As String     '反义词Dim re As ObjectDim rl As ObjectDim st As ObjectDim SplitMark As StringDim resultA As StringDim arrR() As StringDim url As StringDim i, j As IntegerDim str As StringDim wd As StringDim utf8 As StringOn Error Resume Nextutf8 = strToUtf8(str1)splitMarkA = "：</p>"url = "https://fanyici.putongtianxia.com/" & utf8 & "_fanyici.html"Call sendAndget1(url, resultA)  '调用返回数据方法,根据返回数据截取有用信息ReDim arrR(Len(resultA))arrR = Split(resultA, splitMarkA)j = UBound(arrR) - LBound(arrR) + 1str = Right(arrR(1), 10)For i = 1 To Len(str)wd = Mid(str, i, 1)If wd Like "*[一-龥]*" Thenfanyici = fanyici & wdEnd IfNext
End Function

三、运行效果截图