回答編集履歴
1
コメントを大量に付与＆一部コード修正
answer
CHANGED
|
@@ -1,47 +1,73 @@
|
|
|
1
1
|
検索クエリの入ったセルを選択（複数選択可）した状態でMainプロシージャを実行すれば、選択済みのすべてのセルの右隣に、クエリで検索して見つかった1つ目の画像を貼り付けます。
|
|
2
2
|
```lang-vbscript
|
|
3
|
+
'Option Explicitは宣言されていない変数を認めないようにするための特殊な宣言です。
|
|
4
|
+
'これがないといきなり新しい変数を作ることができるようになるため、手軽な反面ミスタイプに気づきにくくなります。
|
|
3
5
|
Option Explicit
|
|
4
6
|
|
|
7
|
+
'ここが起点になります。
|
|
5
8
|
Private Sub Main()
|
|
6
9
|
Dim cell As Range
|
|
10
|
+
'Selection とは選択範囲を表す特殊なオブジェクトです。
|
|
11
|
+
'このオブジェクトはセルを選択していればRangeオブジェクトになるし、
|
|
12
|
+
'画像を選択していればShapeオブジェクトになるなど、実行時まで型が判別できません。
|
|
13
|
+
'For Each ~ Nextは範囲を持ったオブジェクト（配列や連想配列など）をすべて舐めるための構文です。
|
|
14
|
+
'Excel VBAにおいてはRangeオブジェクトにも使えるため、このようにしています。
|
|
7
15
|
For Each cell In Selection
|
|
8
16
|
Call GoogleSearch(cell)
|
|
9
17
|
Next
|
|
10
18
|
End Sub
|
|
11
19
|
|
|
20
|
+
'Google画像検索して貼り付けるまでの一連の流れを取りまとめるためのプロシージャです。
|
|
12
21
|
Private Sub GoogleSearch(ByRef cell As Range)
|
|
13
22
|
Dim query As String
|
|
23
|
+
'セルに含まれる値を取り出し、文字列型にします。数字や時刻であっても文字列になります。
|
|
14
24
|
query = CStr(cell.Value2)
|
|
15
25
|
|
|
16
26
|
Dim html As String
|
|
27
|
+
'指定のURLにアクセスして、サーバから返ってくるHTMLをテキストで取得します。
|
|
17
28
|
html = FetchHtml("https://www.google.co.jp/search?tbm=isch&q=" & query)
|
|
18
29
|
|
|
19
30
|
Dim nextUrl As String
|
|
31
|
+
'HTMLテキストを探索して、最初に見つかる画像URLを取り出します。
|
|
20
32
|
nextUrl = FindFirstUrlFromGoogleImageSearch(html)
|
|
21
33
|
|
|
34
|
+
'上で得た画像URLにアクセスし、ファイルをダウンロードして一時フォルダに保存します。
|
|
22
35
|
DownloadFileToTempDir nextUrl
|
|
23
36
|
|
|
37
|
+
'一時フォルダに保存された画像をシートに貼り付けます。
|
|
24
38
|
AddPicture cell
|
|
25
39
|
End Sub
|
|
26
40
|
|
|
41
|
+
'変数[url]にアクセスしてHTMLをテキストで返します。
|
|
27
42
|
Private Function FetchHtml(ByVal url As String) As String
|
|
43
|
+
'JavaScriptではXMLHttpRequestと呼ばれるオブジェクトです。
|
|
28
44
|
Dim xhr As Object
|
|
29
45
|
Set xhr = CreateObject("MSXML2.XMLHTTP")
|
|
30
46
|
|
|
47
|
+
'GETリクエストを非同期で要求するよう接続をオープンします。
|
|
31
48
|
xhr.Open "GET", url, True
|
|
49
|
+
'要求を送信します。
|
|
32
50
|
xhr.send
|
|
33
51
|
|
|
52
|
+
'Do (While|Until) ~ Loopは与えられた条件が成り立っている間、あるいは成り立つまで繰り返します。
|
|
34
53
|
Do Until xhr.readyState = 4
|
|
54
|
+
'DoEventsはウィンドウメッセージを処理させる命令です。
|
|
55
|
+
'待機中、画面が応答なしになるのを防ぐ、くらいに思っておけばいいでしょう。
|
|
35
56
|
DoEvents
|
|
36
57
|
Loop
|
|
37
58
|
|
|
59
|
+
'応答結果を返り値に設定します。
|
|
38
60
|
FetchHtml = xhr.responseText
|
|
39
61
|
|
|
62
|
+
'オブジェクト解放
|
|
40
63
|
Set xhr = Nothing
|
|
41
64
|
End Function
|
|
42
65
|
|
|
43
66
|
Private Sub DownloadFileToTempDir(ByVal url As String)
|
|
44
67
|
'ref: http://www.ka-net.org/blog/?p=4855
|
|
68
|
+
|
|
69
|
+
'定数宣言です。
|
|
70
|
+
'定数とは、変数と違って一度定義したら変えられない特殊な変数のようなものです。
|
|
45
71
|
Const adTypeBinary = 1
|
|
46
72
|
Const adSaveCreateOverWrite = 2
|
|
47
73
|
|
|
@@ -49,6 +75,7 @@
|
|
|
49
75
|
Set xhr = CreateObject("MSXML2.XMLHTTP")
|
|
50
76
|
|
|
51
77
|
xhr.Open "GET", url, True
|
|
78
|
+
'HTTPヘッダを設定します。詳しくはネットワーク系の基礎を勉強してください。
|
|
52
79
|
xhr.setRequestHeader "Pragma", "no-cache"
|
|
53
80
|
xhr.setRequestHeader "Cache-Control", "no-cache"
|
|
54
81
|
xhr.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
|
|
@@ -58,40 +85,67 @@
|
|
|
58
85
|
DoEvents
|
|
59
86
|
Loop
|
|
60
87
|
|
|
88
|
+
'ADODB.Streamはデータストリームを汎用的に扱うためのAPI群を提供します。
|
|
61
89
|
With CreateObject("ADODB.Stream")
|
|
90
|
+
'保存するものは画像なので、扱うデータはバイナリであることを設定しています。
|
|
91
|
+
'ファイルをメモ帳で開いて文字化けしていなかったら「テキスト」、それ以外はすべて「バイナリ」くらいの認識でいいです。
|
|
62
92
|
.Type = adTypeBinary
|
|
93
|
+
'ストリームをオープンします。
|
|
63
94
|
.Open
|
|
95
|
+
'ストリームにデータを書き込みます。中身はバイナリなので人間には読めません。
|
|
64
96
|
.Write xhr.responseBody
|
|
97
|
+
'ストリームの中身をファイルに出力します。
|
|
65
98
|
.SaveToFile Environ("TEMP") & "\vbatemp", adSaveCreateOverWrite
|
|
99
|
+
'ストリームを閉じます。
|
|
66
100
|
.Close
|
|
67
101
|
End With
|
|
102
|
+
|
|
103
|
+
'オブジェクト解放
|
|
104
|
+
Set xhr = Nothing
|
|
68
105
|
End Sub
|
|
69
106
|
|
|
107
|
+
'HTMLテキストから最初に見つかる画像URLを返します。
|
|
70
108
|
Private Function FindFirstUrlFromGoogleImageSearch(ByVal html As String) As String
|
|
71
109
|
Dim partOfHtml As String
|
|
110
|
+
'Long型は32bit長のビットで表せる整数です。VB.NETでのLong（こちらは64bit）とは別物です。
|
|
72
111
|
Dim idx As Long
|
|
73
112
|
|
|
113
|
+
'HTMLソースの何文字目に "imgurl=" という文字列が含まれるのかを idx に格納します。
|
|
74
114
|
idx = InStr(html, "imgurl=")
|
|
115
|
+
'idx + 7 番目から後の文字列を抽出します。
|
|
75
116
|
partOfHtml = Mid(html, idx + 7)
|
|
117
|
+
'抽出後の文字列の何番目に "&" という文字列が含まれるのかを idx に格納します。
|
|
76
118
|
idx = InStr(partOfHtml, "&")
|
|
77
119
|
|
|
120
|
+
'最初から idx - 1 番目までを抽出して、返り値に設定します。
|
|
78
121
|
FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)
|
|
79
122
|
End Function
|
|
80
123
|
|
|
124
|
+
'与えられたRange型（セル）の右隣に、あらかじめ保存された画像を貼り付けます。
|
|
81
125
|
Private Sub AddPicture(ByRef cell As Range)
|
|
82
126
|
Dim shape As shape
|
|
127
|
+
'ここの詳しいパラメータの機能は私もよくは知りません。
|
|
83
128
|
Set shape = ActiveSheet.Shapes.AddPicture( _
|
|
84
129
|
Filename:=Environ("TEMP") & "\vbatemp", _
|
|
130
|
+
'Excelでの画像貼り付けには複数の方法があり、
|
|
131
|
+
'ファイルへのリンクとするのかExcelファイル自体に画像を含ませるのかを選択できます。
|
|
132
|
+
'ここではExcelファイルに埋め込んでいます。
|
|
85
133
|
LinkToFile:=False, _
|
|
86
134
|
SaveWithDocument:=True, _
|
|
135
|
+
'シートのA1の左上隅を頂点として、右にどのくらいずらすのかを指定します。
|
|
87
136
|
Left:=cell.Left + cell.width, _
|
|
137
|
+
'シートのA1の左上隅を頂点として、下にどのくらいずらすのかを指定します。
|
|
88
138
|
Top:=cell.Top, _
|
|
139
|
+
'貼り付ける画像の縦幅、横幅を指定します。
|
|
140
|
+
'ここでは両方とも 0 に指定していますが、下でさらに別の設定をしています。
|
|
89
141
|
width:=0, _
|
|
90
142
|
height:=0)
|
|
91
143
|
|
|
144
|
+
'貼り付けられた画像の縦幅横幅を、画像そのものの大きさに一致するようにします。
|
|
92
145
|
shape.ScaleHeight 1, msoTrue
|
|
93
146
|
shape.ScaleWidth 1, msoTrue
|
|
94
147
|
|
|
148
|
+
'オブジェクト解放
|
|
95
149
|
Set shape = Nothing
|
|
96
150
|
End Sub
|
|
97
151
|
```
|