在线成语查询器-Excel成语查询

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

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

Office3658

 

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

点击加入群：OFFICE3658 结识Excel大神

学好Excel,效率成倍提高，薪水稳步增长，职位快速提升
每天一个源创技巧，如觉得有用，请点上面 关注。更重要手机转发分享

如喜欢此技巧，手机右上角点开，分享到QQ空间，方便自己以后看