前面我们也介绍过部分网抓实例。通过调用网页的数据来填充我们需要的内容。
这个实例是成语查询的,通过输入成语,获取拼音和释义。
作者:小林子-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
如喜欢此技巧,手机右上角点开,分享到QQ空间,方便自己以后看