有VBA，成语接龙不再难

有VBA，成语接龙不再难

---

前言

中华文化博大精深，文言文言简意赅。虽然我们日常生活中不再使用文言文，但文言文仍是我们从小学开始一直学习的必修课。成语是我们日常生活中经常使用的，是渗透在我们中华儿女的骨子里的语言精华。成语接龙，现在仍是我们学习、休闲时常见的娱乐节目。
但你是不是常有提笔忘字、张口语塞的感觉，在成语接龙时也是这样。本来觉得能说出的成语很多，可就是想不起来一个。让VBA代码来帮你。
现在网络很发达，随便搜索成语，便能出来好几页。这次我们还是在网上提取数据，不需要费大力气自建成语数据库。本次用的数据为“查字典”的“成语”版块。

---

一、网站截图

二、操作思路

1、先建一个获取成语接龙数据的方法。向网站发送一条带开头成语的信息，将返回信息进行加工截取，将返回的成语打包保存在一维数组内；2、该网站返回的成语数量为9个，为获取数据方便，将数组内容转换成一个字符串，放在一个单元格内。如接龙的数据需求超过9个，可重复该操作，即用返回的最后一个成语再获取一次数据，以此类推。
有三个小问题，一个是获取数据前必须打开浏览器，否则会出现“404”错误；另一个是返回的数据，即同一个成语，返回的接龙成语是完全一样的，不管重复多少次；换一个成语，和上一个成语末尾字相同，但返回的接龙成语不一样。这应该是网站的问题；第三个问题是返回的成语很生辟，不知是不是我少见多怪。大家可以换其他的网站试试，效果截图放在最后。

---

三、代码

Function Idioms(idiom As String, arrIdioms() As Variant)
  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 i, j As Integer
  On Error Resume Next
  SplitMark = "</a><i οnclick="
  Set ie = CreateObject("InternetExplorer.Application")       '打开Ie浏览器，不打开会报"404"错误，不知为何
  url = "https://www.chazidian.com/cyjl/" & idiom & "/?zishu=1&yuantongyin=2&shunxu=1"
    With ie
     .Visible = False
     .navigate url
    Do Until Not ie.Busy And ie.READYSTATE = 4
     DoEvents
    Loop
    End With
    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
      ReDim arrR(Len(resultA))
      arrR = Split(resultA, SplitMark)
      j = UBound(arrR) - LBound(arrR) + 1
      ReDim arrIdioms(j - 3)
      For m = 1 To j - 2
        arrIdioms(m - 1) = Right(arrR(m), 4)
      Next
End Function
Function IdiomsA(idiom As String) As String
   Dim arrIdiomsA() As Variant
   ReDim arrIdiomsA(9)
   
   On Error Resume Next
   r = Selection.Row
   c = Selection.Column
   Call Idioms(idiom, arrIdiomsA())
   arrLen = UBound(arrIdiomsA) - LBound(arrIdiomsA) + 1
   For i = 0 To arrLen - 1
    If i < arrLen - 1 Then
      IdiomsA = IdiomsA + arrIdiomsA(i) + ","
    Else
      IdiomsA = IdiomsA + arrIdiomsA(i)
    End If
   Next
End Function

四、运行效果截图