teratail header banner
teratail header banner
質問するログイン新規登録

質問編集履歴

2

構文間違え

2015/04/19 07:37

投稿

ttt1212
ttt1212

スコア16

title CHANGED
File without changes
body CHANGED
@@ -91,7 +91,7 @@
91
91
  .Type = adTypeBinary
92
92
  .Open
93
93
  .Write xhr.responseBody
94
- .SaveToFile ActiveWorkbook.Path & "\vbatemp", adSaveCreateOverWrite
94
+ .SaveToFile Environ("TEMP") & "\vbatemp", adSaveCreateOverWrite
95
95
  .Close
96
96
  End With
97
97
  End Sub

1

現在のコードを記載

2015/04/19 07:37

投稿

ttt1212
ttt1212

スコア16

title CHANGED
File without changes
body CHANGED
@@ -30,4 +30,99 @@
30
30
  ‘objIE.Quit
31
31
  ‘Set objIE = Nothing
32
32
 
33
- End Sub
33
+ End Sub
34
+
35
+ ーーーーーーーー
36
+ 整理のため、今一度コードを現在のコードを記載します。
37
+ ※htsignさんより回答いただき、下記のように編集いたしました。
38
+ ```lang-VBAスプリクト
39
+ Option Explicit
40
+
41
+ Private Sub Main()
42
+ Call GoogleSearch(ActiveCell.Value2)
43
+ End Sub
44
+
45
+ Private Sub GoogleSearch(ByVal query As String)
46
+ Dim html As String
47
+ html = FetchHtml("https://www.google.co.jp/search?tbm=isch&q=" & query)
48
+
49
+ Dim nextUrl As String
50
+ nextUrl = FindFirstUrlFromGoogleImageSearch(html)
51
+
52
+ DownloadFileToTempDir nextUrl
53
+
54
+ AddPicture
55
+ End Sub
56
+
57
+ Private Function FetchHtml(ByVal url As String) As String
58
+ Dim xhr As Object
59
+ Set xhr = CreateObject("MSXML2.XMLHTTP")
60
+
61
+ xhr.Open "GET", url, True
62
+ xhr.send
63
+
64
+ Do Until xhr.readyState = 4
65
+ DoEvents
66
+ Loop
67
+
68
+ FetchHtml = xhr.responseText
69
+
70
+ Set xhr = Nothing
71
+ End Function
72
+
73
+ Private Sub DownloadFileToTempDir(ByVal url As String)
74
+ Const adTypeBinary = 1
75
+ Const adSaveCreateOverWrite = 2
76
+
77
+ Dim xhr As Object
78
+ Set xhr = CreateObject("MSXML2.XMLHTTP")
79
+
80
+ xhr.Open "GET", url, True
81
+ xhr.setRequestHeader "Pragma", "no-cache"
82
+ xhr.setRequestHeader "Cache-Control", "no-cache"
83
+ xhr.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
84
+ xhr.send
85
+
86
+ Do Until xhr.readyState = 4
87
+ DoEvents
88
+ Loop
89
+
90
+ With CreateObject("ADODB.Stream")
91
+ .Type = adTypeBinary
92
+ .Open
93
+ .Write xhr.responseBody
94
+ .SaveToFile ActiveWorkbook.Path & "\vbatemp", adSaveCreateOverWrite
95
+ .Close
96
+ End With
97
+ End Sub
98
+
99
+ Private Function FindFirstUrlFromGoogleImageSearch(ByVal html As String) As String
100
+ Dim partOfHtml As String
101
+ Dim idx As Long
102
+
103
+ idx = InStr(html, "imgurl=")
104
+ partOfHtml = Mid(html, idx + 7)
105
+ idx = InStr(partOfHtml, "&")
106
+
107
+ FindFirstUrlFromGoogleImageSearch = Left(partOfHtml, idx - 1)
108
+ End Function
109
+
110
+ Private Sub AddPicture()
111
+ Dim shape As shape
112
+ Set shape = ActiveSheet.Shapes.AddPicture( _
113
+ Filename:=Environ("TEMP") & "\vbatemp", _
114
+ LinkToFile:=False, _
115
+ SaveWithDocument:=True, _
116
+ Left:=ActiveCell.Left + ActiveCell.Width, _
117
+ Top:=ActiveCell.Top, _
118
+ Width:=0, _
119
+ Height:=0)
120
+
121
+ shape.ScaleHeight 1, msoTrue
122
+ shape.ScaleWidth 1, msoTrue
123
+
124
+ Set shape = Nothing
125
+
126
+ End Sub
127
+
128
+ ```