Excel成语查询

前面我们也介绍过部分网抓实例。通过调用网页的数据来填充我们需要的内容。

这个实例是成语查询的，通过输入成语，获取拼音和释义。

作者：小林子-Office中国

Excel成语查询操作动画

 Excel成语查询详细VBA代码：               

            Function cy(str As String) As String

                On Error Resume Next

                Application.ScreenUpdating = False

                Dim 网址 As String

                网址 = "http://v.juhe.cn/chengyu/query?key=eea5bd36b4ccb905347b22014b4307c5&dtype=xml&word="

                Dim 成语 As String

                成语 = UrlEncode(str)

                Dim ARR1() As String

                Dim objXML As Object

                Dim txtContent As String

                Set objXML = CreateObject("Microsoft.XMLHTTP")

                With objXML

                    .Open "GET", 网址 & 成语, False

                    .send

                    If objXML.Status = 200 Then

                        txtContent = .responsetext

                        ARR1 = Split(txtContent, ">")                        

                       cy = Left(ARR1(10), Len(ARR1(10)) - 8) & " " & Left(ARR1(12), Len(ARR1(12)) - 11)                  

                    Else              

                        MsgBox "下载网页数据失败"                     

                    End If                    

                End With                

                'Set objXML = Nothing                

                ThisWorkbook.Save                

                Application.ScreenUpdating = True                

            End Function

            '把汉字转换成url字符编码

            Public Function UrlEncode(ByRef szString As String) As String

                Dim szChar  As String

                Dim szTemp  As String

                Dim szCode  As String

                Dim szHex  As String

                Dim szBin  As String

                Dim iCount1 As Integer

                Dim iCount2 As Integer

                Dim iStrLen1 As Integer

                Dim iStrLen2 As Integer

                Dim lResult As Long

                Dim lAscVal As Long

                szString = Trim$(szString)

                iStrLen1 = Len(szString)

                For iCount1 = 1 To iStrLen1

                  szChar = Mid$(szString, iCount1, 1)

                  lAscVal = AscW(szChar)

                  If lAscVal >= &H0 And lAscVal <= &HFF Then

                   If (lAscVal >= &H30 And lAscVal <= &H39) Or _

                     (lAscVal >= &H41 And lAscVal <= &H5A) Or _

                     (lAscVal >= &H61 And lAscVal <= &H7A) Then

                     szCode = szCode & szChar

                   Else

                     szCode = szCode & "%" & Hex(AscW(szChar))

                   End If

                  Else

                   szHex = Hex(AscW(szChar))

                   iStrLen2 = Len(szHex)

                   For iCount2 = 1 To iStrLen2

                     szChar = Mid$(szHex, iCount2, 1)

                     Select Case szChar

                         Case Is = "0"

                           szBin = szBin & "0000"

                         Case Is = "1"

                           szBin = szBin & "0001"

                         Case Is = "2"

                           szBin = szBin & "0010"

                         Case Is = "3"

                           szBin = szBin & "0011"

                         Case Is = "4"

                           szBin = szBin & "0100"

                         Case Is = "5"

                        szBin = szBin & "0101"

                         Case Is = "6"

                           szBin = szBin & "0110"

                         Case Is = "7"

                           szBin = szBin & "0111"

                         Case Is = "8"

                           szBin = szBin & "1000"

                         Case Is = "9"

                           szBin = szBin & "1001"

                         Case Is = "A"

                           szBin = szBin & "1010"

                         Case Is = "B"

                           szBin = szBin & "1011"

                         Case Is = "C"

                           szBin = szBin & "1100"

                         Case Is = "D"

                           szBin = szBin & "1101"

                         Case Is = "E"

                           szBin = szBin & "1110"

                         Case Is = "F"

                           szBin = szBin & "1111"

                         Case Else

                     End Select

                   Next iCount2

                   szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)

                   For iCount2 = 1 To 24

                     If Mid$(szTemp, iCount2, 1) = "1" Then

                       lResult = lResult + 1 * 2 ^ (24 - iCount2)

                     Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)

                     End If

                   Next iCount2

                   szTemp = Hex(lResult)

                      szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)

                  End If

                  szBin = vbNullString

                  lResult = 0

                Next iCount1

                UrlEncode = szCode

            End Function