概要
エクセルVBAから、IE(インターネットエクスプローラー)を使って、ホームページを開き、データ検索などの操作する時のメモです。
成果物
(1)書籍検索
下の図は、エクセルシートの黄色部分にキーワードを入力し、検索ボタンをクリックすると実際に市販されている書籍を検索し、タイトルと価格を表に出力するものです。
具体的名称等は省略しますが、実際にある某書店の検索ページを開き、キーワード入力・検索ボタンをクリックして得られる結果から、データを取得しています。
(2)英単語検索
次の図は、エクセルシートの最左列に複数の英単語を入力し、検索ボタンをクリックすると(1)同様にインターネットエクスプローラーで検索サイトを開き、意味を取得し表示するものです。
参照設定
先ず準備として、参照設定を追加します。
① Microsoft HTML Object Library
② Microsoft Internet Controls
プログラム
検索はホームページのタグ名、クラス名等を利用して情報を取得しています。予めブラウザーの検証機能等を利用し、HTML上にデータが記載されている場所とデータ取得方法などを確認しておく必要があります。
(1)書籍検索
'シート側コマンドボタン Private Sub CommandButton1_Click()
Call ie_search_book_info
End Sub '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※ Option Explicit #If Win64 Then Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Public Sub ie_search_book_info() Dim objIE As InternetExplorer Dim objtag As Object Dim objTmp As Object Dim timeOut As Date Dim tmp, sht Dim book_name Dim book_info Dim bookPrice Dim cnt sht = ActiveSheet.Name Worksheets(sht).Range("A5:B200").ClearContents book_name = Trim(Worksheets(sht).Cells(2, 1).Value) On Error GoTo errHandler Set objIE = CreateObject("InternetExplorer.Application") ' IEオブジェクト作成 objIE.Visible = True ' IE起動 objIE.navigate "<省略:検索サイトURL>" ' 完全に表示されるまで待機 timeOut = Now + TimeSerial(0, 0, 20) Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Sleep 1 If Now > timeOut Then objIE.Refresh timeOut = Now + TimeSerial(0, 0, 20) End If Loop ' 書籍名を設定 For Each objtag In objIE.document.getElementsByTagName("input") If objtag.getAttribute("class") = "[省略:クラス名]" Then objtag.innerText = book_name Exit For End If Next ' 検索ボタンをクリック For Each objtag In objIE.document.getElementsByTagName("input") If objtag.getAttribute("class") = "[省略:クラス名]" Then objtag.Click Exit For End If Next Sleep (200) ' 完全に表示されるまで待機 timeOut = Now + TimeSerial(0, 0, 20) Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Sleep 1 If Now > timeOut Then objIE.Refresh timeOut = Now + TimeSerial(0, 0, 20) End If Loop Sleep (500) ' 検索結果から、書籍名・価格を取得 cnt = 0 For Each objtag In objIE.document.getElementsByTagName("div") tmp = objtag.getAttribute("class") If InStr(tmp, "[省略:クラス名]") > 0 Then book_info = objtag.getElementsByTagName("h3")(0).innerText bookPrice = "" For Each objTmp In objtag.getElementsByTagName("span") If objTmp.getAttribute("class") = "[省略:クラス名]" Then bookPrice = objTmp.innerText End If Next Worksheets(sht).Cells(5 + cnt, 1).Value = book_info Worksheets(sht).Cells(5 + cnt, 2).Value = bookPrice cnt = cnt + 1 End If Next objIE.Quit ' IEを閉じる Set objIE = Nothing Exit Sub ' エラー処理 errHandler: objIE.Quit Set objIE = Nothing On Error GoTo 0 End Sub
(2)英単語検索
'シート側コマンドボタン Private Sub CommandButton1_Click() Dim sht, wrd Dim cnt Dim ret sht = ActiveSheet.Name cnt = 0 Do wrd = Trim(Worksheets(sht).Cells(5 + cnt, 1).Value) If wrd = "" Then Exit Do wrd = StrConv(StrConv(wrd, 8), 2) ret = ie_search_e_word(wrd) Worksheets(sht).Cells(5 + cnt, 2).Value = ret DoEvents cnt = cnt + 1 Loop End Sub '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※ Option Explicit #If Win64 Then Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '// 指定URLファイルのダウンロード Public 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 '// キャッシュクリア Public Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long #Else Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '// 指定URLファイルのダウンロード Public 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 '// キャッシュクリア Public Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long #End If ' 単語検索 Public Function ie_search_e_word(s_word) Dim objIE As InternetExplorer Dim objtag As Object Dim timeOut As Date Dim tmp Dim ret Dim cntnt(2) On Error GoTo errHandler ie_search_e_word = "" Set objIE = CreateObject("InternetExplorer.Application") ' IEオブジェクト作成 objIE.Visible = True ' IE起動 objIE.navigate "<省略:検索サイトURL>" + s_word ' 単語を検索する ' 完全に表示されるまで待機 timeOut = Now + TimeSerial(0, 0, 20) Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Sleep 1 If Now > timeOut Then objIE.Refresh timeOut = Now + TimeSerial(0, 0, 20) End If Loop ' 主な意味取得 For Each objtag In objIE.document.getElementsByTagName("td") tmp = objtag.outerHTML If InStr(tmp, "[省略:クラス名]") > 0 Then cntnt(0) = objtag.innerText Exit For End If Next ie_search_e_word = cntnt(0) ' 音声ファイル取得 For Each objtag In objIE.document.getElementsByTagName("[省略]")(0).getElementsByTagName("[省略]") cntnt(1) = objtag.getAttribute("[省略]") ' URL取得 Exit For Next ' 音声ファイルをダウンロード ret = -1 If cntnt(1) <> "" Then If Right(cntnt(1), 4) = ".mp3" Then cntnt(2) = "[省略]" + s_word + Right(cntnt(1), 4) Call DeleteUrlCacheEntry(cntnt(1)) ' キャッシュクリア ret = URLDownloadToFile(0, cntnt(1), cntnt(2), 0, 0) ' ダウンロード End If End If objIE.Quit ' IEを閉じる Set objIE = Nothing Exit Function ' エラー処理 errHandler: objIE.Quit Set objIE = Nothing On Error GoTo 0 End Function
クリック処理
(1)書籍検索 のプログラム行番59の様にブラウザ内ボタンをクリックし処理を進めることがあります。今回の場合は特に問題はありませんが、最終確認や入力内容チェック結果などをメッセージボックスで表示することがあります。その場合、❛OK❜ボタンをクリックするなどして、メッセージボックスを消すまでVBAプログラムは先に進みません。
次の行番13の様に javascript でクリックをすることでVBAプログラムは停止しません。次にメッセージボックスのウィンドウハンドルを取得し、SendMessage でクリック相当処理を行い、メッセージボックスを消すことが出来ます。
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Const WM_COMMAND = &H111 '******************************************************************** Dim hwnd As Long objIE.Document.Script.setTimeout "javascript:document.getElementByName('[省略]')(0).click()", 200 hwnd = FindWindow("#32770", "Web ページからのメッセージ") While hwnd = 0 DoEvents Sleep 1 hwnd = FindWindow("#32770", "Web ページからのメッセージ") Wend SendMessage hwnd , WM_COMMAND, vbOK, ByVal 0&
まとめ
息子が中高生の時に勉強を手伝って、英単語を調べたりしていました。その時、この方法を知っていれば、もっと楽に調査できたと思います。
でも、きっとまた使えることもあるでしょう。