当前位置:   article > 正文

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

自建公式,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
  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 7
  • 8
  • 9
  • 10
  • 11
  • 12
  • 13
  • 14
  • 15
  • 16
  • 17
  • 18
  • 19
  • 20
  • 21
  • 22
  • 23
  • 24
  • 25
  • 26
  • 27
  • 28
  • 29
  • 30
  • 31
  • 32
  • 33

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

  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 7
  • 8
  • 9
  • 10
  • 11
  • 12
  • 13
  • 14
  • 15
  • 16
  • 17
  • 18
  • 19
  • 20
  • 21
  • 22
  • 23
  • 24
  • 25
  • 26
  • 27
  • 28
  • 29
  • 30
  • 31
  • 32
  • 33
  • 34
  • 35
  • 36
  • 37
  • 38
  • 39

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
  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 7
  • 8
  • 9
  • 10
  • 11
  • 12
  • 13
  • 14
  • 15
  • 16
  • 17
  • 18
  • 19
  • 20
  • 21
  • 22
  • 23
  • 24
  • 25
  • 26
  • 27
  • 28

三、运行效果截图

提示:这里对文章进行总结:
例如:以上就是今天要讲的内容,本文仅仅简单介绍了pandas的使用,而pandas提供了大量能使我们快速便捷地处理数据的函数和方法。

声明:本文内容由网友自发贡献,不代表【wpsshop博客】立场,版权归原作者所有,本站不承担相应法律责任。如您发现有侵权的内容,请联系我们。转载请注明出处:https://www.wpsshop.cn/w/小小林熬夜学编程/article/detail/627571
推荐阅读
相关标签
  

闽ICP备14008679号