用VBA下载google图片

ccwan

篇外话：我是2006年911注册的会员（只是巧合，并非有意），但是实际在线时间有限。在这里，看到了很多的牛人， 我从各位版主、会员等达人那里学到了很多，尽管我不可能学得很深入，毕竟我不是专业人士，甚至也没有上过大学，但我依然觉得自己有了很大的进步，在此感谢各位。

言归正传

经过搜索，没有发现有用vba下载google图片的帖子（或者是我没找到？），于是便凑了点代码，和大家分享。已经加上了注释，便于新手理解。
千万不要嫌下载速度慢哦，IE嘛。要快的话，还是用下载软件的好。

1. Sub cc()
   
2.     Dim s, ss(), r%, i&, j&
   
3.     IName = "刘亦菲"          '这里确定要下载谁的图片
   
4.     Path = ThisWorkbook.Path & ""
   
5.     MkDir Path & IName        '建立文件夹以便存放图片
   
6.     On Error Resume Next
   
7.     Set ie = CreateObject("Msxml2.XMLHTTP")
   
8.     For r = 0 To 100 Step 20  '这里控制你要下载几张网页的图片 _
   
9.     —如果你定的数字很大，那么恭喜你，你可以休息很长时间了，呵呵
   
10.         ie.Open "GET", "http://images.google.cn/images?gbv=2&hl=zh-CN&newwindow=1&q=" & IName & "&sa=N&start=" & r & "&ndsp=20"", true"
    
11.         ie.Send
    
12.         Do Until ie.ReadyState = 4
    
13.             DoEvents
    
14.         Loop                                '等待网页处理完成再运行下面的代码
    
15.         s = Split(ie.responseText, """")    '把源文件中的引号替换成换行，以便提取图片链接
    
16.         For i = 0 To UBound(s)
    
17.             If s(i) Like "http://*" Then
    
18.                 If InStr(s(i), "jpg") Then    '这里两行查找含有图片地址的链接
    
19.                     j = j + 1
    
20.                     ReDim Preserve ss(1 To j)
    
21.                     ss(j) = s(i)              '把含有图片地址的链接址传递给数组ss
    
22.                 End If
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     For i = 1 To UBound(ss)
    
27.         ie.Open "GET", ss(i), False
    
28.         ie.Send
    
29.         Do Until ie.ReadyState = 4
    
30.             DoEvents
    
31.         Loop
    
32.         With CreateObject("ADODB.Stream")
    
33.             .Type = 1
    
34.             .Open
    
35.             .write ie.Responsebody
    
36.             .savetofile Path & i & ".jpg", 2   '以序号为名称另存图片
    
37.             .Close
    
38.         End With
    
39.         Name Path & i & ".jpg" As Path & IName & "" & i & ".jpg" '把下载下来的图片移到文件夹中
    
40.     Next
    
41. End Sub

复制代码

[ 本帖最后由 ccwan 于 2009-12-11 15:56 编辑 ]

ericfei

踩下，留个脚印。

xibeiakang

技术很好，创意很好。支持你

lb_bn

楼主高人啊，学习。

ccwan

lb_bn兄谬赞了，看到兄这些天的回复，就知我比你差得远呢。

飞云楼主

支持一下，收下学习。

lb_bn

客气了，ccwan老师的功力比我高很多。

northwolves

已知图片地址,可使用API:URLDownloadToFile 进行下载,GOOGLE搜之

Moneky

刚刚酒完就来学习了，谢谢！后面肯定会用到的，先留个脚印，谢谢分享！

ccwan

原帖由 northwolves 于 2009-12-11 23:19 发表
已知图片地址,可使用API:URLDownloadToFile 进行下载,GOOGLE搜之

多谢狼版指教。我去搜搜看