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

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

---

前言

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

---

一、爬取网站数据

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

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

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

二、代码

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

Function sendAndget1(url As String, resultA As String)  
  Dim re As Object
  Dim rl As Object
  Dim st As Object
  On Error Resume Next
    Set xmlhttp = CreateObject("msxml2.xmlhttp")
           xmlhttp.Open "GET", url, False
           xmlhttp.send
     If xmlhttp.READYSTATE = 4 Then
       a = StrConv(xmlhttp.RESPONSEBODY, vbUnicode)
     End If
     Set re = CreateObject("vbscript.RegExp")
     With re
        .IgnoreCase = True
        .Global = True
        .Pattern = "utf-8|gb2312|gbk"

       Set rl = .Execute(a)
     End With
     Ch = rl.Item(0)
     Set st = CreateObject("adodb.stream")
   With st
      .Mode = 3
      .Type = 1
      .Open
      .write xmlhttp.RESPONSEBODY
      .Position = 0
      .Type = 2
      .Charset = Ch
      resultA = .readtext
      .Close
   End With
End Function

2.汉字转UTF8编码

Function strToUtf8(str As String) As String     '汉字转UTF8编码
    Dim wch  As String
    Dim uch As String
    Dim szRet As String
    Dim x As Long
    Dim inputLen As Long
    Dim nAsc  As Long
    Dim nAsc2 As Long
    Dim nAsc3 As Long
    
    If str = "" Then
        strToUtf8 = str
        Exit Function
    End If
    inputLen = Len(str)
    For x = 1 To inputLen
        wch = Mid(str, x, 1)
        nAsc = AscW(wch)
    '对于<0的编码　其需要加上65536
        If nAsc < 0 Then nAsc = nAsc + 65536
    '对于<128位的ASCII的编码则无需更改
        If (nAsc And &HFF80) = 0 Then
            szRet = szRet & wch
        Else
            If (nAsc And &HF000) = 0 Then
                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
                
            Else
                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
    strToUtf8 = szRet
End Function

2.获取反义词

Function fanyici(str1 As String) As String     '反义词
  Dim re As Object
  Dim rl As Object
  Dim st As Object
  Dim SplitMark As String
  Dim resultA As String
  Dim arrR() As String
  Dim url As String
  Dim i, j As Integer
  Dim str As String
  Dim wd As String
  Dim utf8 As String
  On Error Resume Next
  utf8 = 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) + 1
     str = Right(arrR(1), 10)
     For i = 1 To Len(str)
      wd = Mid(str, i, 1)
      If wd Like "*[一-龥]*" Then
      fanyici = fanyici & wd
      End If
     Next
End Function

三、运行效果截图