用VBA下載下傳google圖檔

Sub cc()

Dim s, ss(), r%, i&, j&

IName = "***" '這裡确定要下載下傳誰的圖檔

Path = ThisWorkbook.Path & "/"

MkDir Path & IName '建立檔案夾以便存放圖檔

On Error Resume Next

Set ie = CreateObject("Msxml2.XMLHTTP")

For r = 0 To 100 Step 20 '這裡控制你要下載下傳幾張網頁的圖檔 _

—如果你定的數字很大，那麼恭喜你，你可以休息很長時間了，呵呵

ie.Open "GET", "http://images.google.cn/images?gbv=2&hl=zh-CN&newwindow=1&q=" & IName & "&sa=N&start=" & r & "&ndsp=20"", true"

ie.Send

Do Until ie.ReadyState = 4

DoEvents

Loop '等待網頁處理完成再運作下面的代碼

s = Split(ie.responseText, """") '把源檔案中的引号替換成換行，以便提取圖檔連結

For i = 0 To UBound(s)

If s(i) Like "http://*" Then

If InStr(s(i), "jpg") Then '這裡兩行查找含有圖檔位址的連結

j = j + 1

ReDim Preserve ss(1 To j)

ss(j) = s(i) '把含有圖檔位址的連結址傳遞給數組ss

End If

End If

Next

Next

For i = 1 To UBound(ss)

ie.Open "GET", ss(i), False

ie.Send

Do Until ie.ReadyState = 4

DoEvents

Loop

With CreateObject("ADODB.Stream")

.Type = 1

.Open

.write ie.Responsebody

.savetofile Path & i & ".jpg", 2 '以序号為名稱另存圖檔

.Close

End With

Name Path & i & ".jpg" As Path & IName & "/" & i & ".jpg" '把下載下傳下來的圖檔移到檔案夾中

Next

End Sub

在楊志甯兄的提議下，改為使用API:URLDownloadToFile 進行下載下傳

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub cc()

Dim s() As String, r%, i&, j&

IName = "***"

path = ThisWorkbook.path & "/"

MkDir path & IName

On Error Resume Next

With CreateObject("Msxml2.XMLHTTP")

For r = 0 To 100 Step 20

.Open "GET", "http://images.google.cn/images?gbv=2&hl=zh-CN&newwindow=1&q=" & IName & "&sa=N&start=" & r & "&ndsp=20"", true"

.Send

Do Until .ReadyState = 4

DoEvents

Loop

s = Split(.responseText, """")

For i = 0 To UBound(s)

If s(i) Like "http://*" Then

If InStr(s(i), "jpg") Then

j = j + 1

URLDownloadToFile 0, s(i), path & IName & "/" & j & ".jpg", 0, 0

End If

End If

Next

Next

End With

End Sub