ExcelVBAでGoogle画像検索の画像を一括でダウンロードしてみた
この動画のマクロはWindows11/Office2016で作成してます。
画像をクリックしてダウンロード
#If VBA7 Then
Declare PtrSafe 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
Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#Else
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
Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#End If
Const c_ダウンロード最大数 = 99
Sub test1()
'クリックするやつ
Call dlImgGoogle("ゆっくり魔理沙", "thumbnail")
End Sub
Sub dlImgGoogle(keyword, FolderName)
Dim driver As New Selenium.WebDriver
If keyword = "" Then Exit Sub
'このExcelファイルのパス
CurrentDirectory = ThisWorkbook.path
Set fso = CreateObject("Scripting.FileSystemObject")
If FolderName = fso.GetAbsolutePathName(FolderName) Then
path = FolderName
Debug.Print "絶対パス path = "; path
Else
path = fso.BuildPath(CurrentDirectory, FolderName)
Debug.Print "相対パス " & FolderName & "->path = "; path
End If
'フォルダーがない場合フォルダーを作成する。
If Not (fso.FolderExists(path)) Then
Debug.Print "新規作成パス path = "; path
fso.CreateFolder path
End If
driver.Start "Chrome"
driver.Get "https://www.google.co.jp/search?&source=lnms&tbm=isch&&q=" & keyword
driver.Wait 100
'検索結果
弟ノードの1番目のdivの配下で、role=buttonの属性を持つaを取得
Set dom_a = driver.FindElementsByXPath("//h1[contains(text(), '検索結果')]/following-sibling::div/div[1]//a[contains(@role,'button')]")
Debug.Print "検索数1", dom_a.Count
'拡張子を判定するための正規表現
Set re = CreateObject("VBScript.RegExp")
re.IgnoreCase = True
re.Pattern = "\.(jpeg|jpg|png|bmp|gif)"
For i = 1 To WorksheetFunction.Min(dom_a.Count, c_ダウンロード最大数)
'画像クリック
driver.ExecuteScript "arguments[0].click();", dom_a(i)
driver.Wait 200
'検索結果の弟ノードの2番目のdivの中から、aを親に持つimgを取得
Set dom_img = driver.FindElementsByXPath("//h1[contains(text(), '検索結果')]/following-sibling::div/div[2]//a[contains(@role,'link')]/img")
Debug.Print "検索数2", dom_img.Count
'imgのsrcにurlが出現するまで待つ
wait_time = 500 'うまくいかない場合ここを伸ばす
For t = 1 To 20
'最初の画像(i=1)のみ1番目のimgに目的のオブジェクトが存在する。それ以外は2番目
If i = 1 Then
driver.Wait wait_time
str_name = dom_img(1).Attribute("alt")
str_url = dom_img(1).Attribute("src")
Else:
driver.Wait wait_time
str_name = dom_img(2).Attribute("alt")
str_url = dom_img(2).Attribute("src")
End If
'srcがhttp形式になったらforを抜ける
If InStr(str_url, "http") > 0 Then Exit For
DoEvents
Next
'urlとして有効なものはダウンロードする
If InStr(str_url, "http") > 0 Then
'拡張子を取得
Set reMatch = re.Execute(str_url)
If reMatch.Count = 1 Then
'画像種別
str_ext = reMatch(0).submatches(0)
str_ext = Replace(str_ext, "jpeg", "jpg") 'jpegはjpgに統一
Else
'拡張子が不明なものはjpgにする
str_ext = "jpg"
End If
'画像のダウンロード先
'検索文字列-1234.jpgのような名前にする
img_file_name = fso.BuildPath(path, keyword & WorksheetFunction.Text(i, "-00#.") & str_ext)
'画像ダウンロード
Debug.Print "img_file_name= "; img_file_name
dowonloaStatus = URLDownloadToFile(0, str_url, img_file_name, 0, 0)
'Debug.Print "dowonloaStatus= "; dowonloaStatus
If dowonloaStatus = 0 Then
'Debug.Print "画像ダウンロードできました"
Else
Debug.Print "画像ダウンロードできませんでした:"; str_url
End If
DoEvents
Else
Debug.Print "画像urlが取得できませんでした:"; str_url
End If
Next
driver.Quit
Set driver = Nothing
End Sub
url一覧を出力するjavascriptの関数
function AF_initDataCallback(x) {
data1=x.data[56][1][0][0][1][0]
for(i=0;i<=data1.length-1;i++) {
data2=data1[i][0][0]["444383007"]
if (data2[1]==null) {break}
item_img_url=data2[1][3][0]
item_name=data2[1][23]["2008"][1]
console.log(i+" "+ (data2[1][23]["2008"][1]))
}
}
url一覧を出力するjavascriptの関数を使ってダウンロード
#If VBA7 Then
Declare PtrSafe 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
Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#Else
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
Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#End If
Const c_ダウンロード最大数 = 99
Sub test2()
'クリックしないやつ
Call dlImgGoogle("ゆっくり魔理沙", "thumbnail")
End Sub
Sub dlImgGoogle2(keyword, FolderName)
Dim driver As New Selenium.WebDriver
'このExcelファイルのパス
CurrentDirectory = ThisWorkbook.path
Set fso = CreateObject("Scripting.FileSystemObject")
If FolderName = fso.GetAbsolutePathName(FolderName) Then
path = FolderName
Debug.Print "絶対パス path = "; path
Else
path = fso.BuildPath(CurrentDirectory, FolderName)
Debug.Print "相対パス " & FolderName & "->path = "; path
End If
If Not (fso.FolderExists(path)) Then
Debug.Print "新規作成パス path = "; path
fso.CreateFolder path
End If
driver.Start "Chrome"
driver.Get "https://www.google.co.jp/search?&source=lnms&tbm=isch&&q=" & keyword
driver.Wait 100
'検索文字列keywordを含んだ このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。
