2019/12/09(月)14:34
VBAでWebスクレイピング_Web翻訳アシスト
無料翻訳のWebアプリをアシストするVBAを作ってみた。
こんな感じ。自動操作で５言語をOutPut。
URL = "https://www.excite.co.jp/world/" '''''''URL設定
With ie
.navigate (URL)
.Visible = True
End With
DocumentTitle = "エキサイト 翻訳" '''''''''''HTMLタイトル設定
Do
Set ie = getIE(DocumentTitle) '''''''画面が出力するまで待機（繰り返す）
If ie Is Nothing Then
Else
Exit Do
End If
Loop
For i = 0 To 4
If i = 0 Then
ii = 4
Else
If i = 1 Then
ii = 6
言語 = "/world/chinese/"
言語x = "before_ch_kn"
End If
If i = 2 Then
ii = 8
言語 = "/world/korean/"
言語x = "before_ko"
End If
If i = 3 Then
ii = 10
言語 = "/world/french/"
言語x = "before_fr"
End If
If i = 4 Then
ii = 12
言語 = "/world/german/"
言語x = "before_de"
End If
For Each objINPUT In ie.Document.all.tags("a") '''''''''言語ボタンを押す
If InStr(objINPUT.outerHTML, 言語) > 0 Then
objINPUT.Click
Exit For
End If
Next
Set objINPUT = Nothing
waittime = Now + TimeValue("0:00:03")
Application.Wait waittime
go = ""
Do
For Each objINPUT In ie.Document.all.tags("a")
If InStr(objINPUT.outerHTML, 言語x) > 0 Then '''''''画面が出力するまで待機（繰り返す） go = "go"
End If
Next
If go = "go" Then Exit Do
Loop
End If
For Each objINPUT In ie.Document.all.tags("a") '''''''''日ボタンを押す
If InStr(objINPUT.outerHTML, "before_ja") > 0 Then
objINPUT.Click
Exit For
End If
Next
waittime = Now + TimeValue("0:00:03")
Application.Wait waittime
key = 翻訳.Range("A2").Value
Set objInpTxt = ie.Document.getElementsByName("before")(0) objInpTxt.Value = key '''''検索キーワード入力
For Each objINPUT In ie.Document.all.tags("input") '''''''''翻訳ボタンを押す
If InStr(objINPUT.outerHTML, "exec_transfer") > 0 Then
objINPUT.Click
Exit For
End If
Next
waittime = Now + TimeValue("0:00:03")
Application.Wait waittime
go = ""
Do
For Each objINPUT In ie.Document.all.tags("textarea") '''''''''スクレイピング
If InStr(objINPUT.outerHTML, "after") > 0 Then
翻訳.Range("A" & ii).Value = objINPUT.outertext
If 翻訳.Range("A" & ii).Value = "" Then go = ""
If 翻訳.Range("A" & ii).Value <> "" Then go = "go"
Exit For
End If
Next
Set objINPUT = Nothing
If go = "go" Then Exit Do
Loop
Next i