需要批量下载网上的图片，Excel行不行？当然行！

……微笑在天上飞 你说你有点难追 想让我知难而退 礼物不需挑最贵 只要香榭的落叶……

上次我们分享了如何使用Excel在当当网上搜索图书信息，并将图书的封面、现价、定价、折扣、链接等数据抓取到Excel：

为了让您买到最廉价的图书，我们用VBA干了这件事……

然后有个朋友问，Excel能不能批量下载网上的图片？譬如说罢，我在百度上搜索了520啊、胡歌啊、杨幂啊甚么滴，想把图片都下载下来……

Excel行不行？

坦白的说，当然……行啊！

照例看个示例动画先。

A2单元格输入搜索的关键字，例如520，点击按钮即可将百度图片搜索结果的前30张图片下载到指定文件夹内。

小贴士：

1，可以下载百度各种类型的图片，比如PNG、JPG、GIF等。图片会被下载到当前Excel工作簿所在路径下的名为图片的文件夹中。如果不存在图片文件夹，代码会自行建立；如果存在图片文件夹，代码会删除该文件夹下所有的文件。

2，图片按序号命名，也就是1~2~3~4~520啊。

3，代码支持64位电脑，如果是32位则需要自行修改API函数，也就是通过查找替换的方式将PtrSafe替换为空白。

4，最后说一个特别认真特别重要的是：我爱你，你知道的。

代码如下（建议点击【阅读原文】下载文件查看）

Private Declare PtrSafe Function URLDownloadToFile Lib 'urlmon' Alias 'URLDownloadToFileA' (ByVal pCaller As Long, ByVal szURL As String, ByVal szExtName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Declare PtrSafe Function DeleteUrlCacheEntry Lib 'wininet' Alias 'DeleteUrlCacheEntryA' (ByVal lpszUrlName As String) As Long

Sub DownloadPictures()

     Dim strKey As String

     Dim strURL As String

     Dim strFolderPath As String

     Dim strText As String

     Dim strPicPath As String

     Dim strPicURL As String

     Dim strExtName As String

     Dim aPageNum As Variant

     Dim aExtName As Variant

     Dim i As Long

     Dim k As Long

     strFolderPath = ThisWorkbook.Path & '\图片\'

     If Dir(strFolderPath, vbDirectory + vbHidden) > '' Then

         If Dir(strFolderPath & '*.*') > '' Then Kill strFolderPath & '*.*'

     Else

         MkDir strFolderPath

     End If

     strKey = [a2].Value

     If Len(strKey) = 0 Then

         MsgBox '未输入查询关键字，程序退出。'

         Exit Sub

     End If

     strKey = encodeURI(strKey) '对查询关键字转码

     With CreateObject('msxml2.xmlhttp') '发送网页请求，获得响应信息

         strURL = 'http://image.baidu.com/search/index?tn=baiduimage&word=' & strKey

         .Open 'GET', strURL, 'False'

         .send

         strText = .responseText

     End With

     aPageNum = Split(strText, '''pageNum'':')

     '按关键字pageNum对响应信息进行拆分

     For i = 1 To UBound(aPageNum)

         If InStr(1, aPageNum(i), 'objURL', vbTextCompare) Then

         '判断是否存在字符串objurl

             k = k + 1

             strPicURL = Split(Split(aPageNum(i), '''objURL'':''')(1), ''',')(0)

             '图片的网址

             aExtName = Split(strPicURL, '.')

             strExtName = '.' & aExtName(UBound(aExtName))

             '图片的后缀名

             strPicPath = strFolderPath & k & strExtName

             '图片保存地址

             DeleteUrlCacheEntry strPicURL

             '删除图片缓存数据

             URLDownloadToFile 0, strPicURL, strPicPath, 0, 0

             '下载图片

         End If

     Next

End Sub

Function encodeURI(strText As String) As String

    Dim objDOM As Object

    Set objDOM = CreateObject('htmlfile')

    With objDOM.parentWindow

        objDOM.Write ''

        encodeURI = .eval('encodeURIComponent('' & strText & '')')

    End With

    Set objDOM = Nothing

End Function

---

图文：看见星光