VBAでWEB検索(IE操作)

概要

 エクセル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&

まとめ

 息子が中高生の時に勉強を手伝って、英単語を調べたりしていました。その時、この方法を知っていれば、もっと楽に調査できたと思います。
 でも、きっとまた使えることもあるでしょう。


コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です