前言
中华文化博大精深,文言文言简意赅。虽然我们日常生活中不再使用文言文,但文言文仍是我们从小学开始一直学习的必修课。成语是我们日常生活中经常使用的,是渗透在我们中华儿女的骨子里的语言精华。成语接龙,现在仍是我们学习、休闲时常见的娱乐节目。
但你是不是常有提笔忘字、张口语塞的感觉,在成语接龙时也是这样。本来觉得能说出的成语很多,可就是想不起来一个。让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