IE操作のためのクラスを作った - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

クラスにしてしまったのでぶちまけておく

f:id:akashi_keirin:20181229210153p:plain

職場のクソWebアプリの攻略の過程で色んなメソッドを作ったので、無駄にクラス化しておいた。

思いつきを行き当たりばったりで形にしただけなので、ツッコミどころはたくさんあると思う。

複数インスタンスを作るシチュエーションも思い浮かばないので、もしかしたらAttribute VB_PredeclaredIdをTrueにしてもいいかもしれない。

いちいち手入れするのもめんどくさいので、ソースコードをそのままぶちまけておく。

どうせ一般ウケは狙ってないし。（←負け惜しみｗ）

WebAppクラス

リスト１　クラスモジュール

オブジェクト名を「WebApp」としています。

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private GotIE_ As InternetExplorer
Private CurrentDocument_ As HTMLDocument

Public Property Get GotIE() As InternetExplorer
  Set GotIE = GotIE_
End Property

Public Property Get CurrentDocument() As HTMLDocument
  On Error Resume Next
    Set CurrentDocument = GotIE_.Document
    If Err.Number > 0 Then Set CurrentDocument = Nothing
  On Error GoTo 0
End Property

Public Property Get PageHTMLSource() As String
  Dim ret As String
  On Error Resume Next
    ret = Me.getHTMLSource
  On Error GoTo 0
  PageHTMLSource = ret
End Property

Private Sub Class_Initialize()
  Set GotIE_ = New InternetExplorer
End Sub

Private Sub Class_Terminate()
  Set GotIE_ = Nothing
  Set CurrentDocument_ = Nothing
End Sub

Public Sub init(ByVal targetURL As String)
  '擬似コンストラクタ'
  With GotIE_
    .Visible = True
    Call .Navigate(targetURL)
    Do While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Loop
    Call waitFor(2000)
  Set CurrentDocument_ = .Document
  End With
End Sub

Public Function getIEByTitle( _
                  ByVal titleKeyWord As String) As InternetExplorer
'タイトルにキーワードを含むページを表示中のIEを取得するメソッド'
  Dim shellApp As New Shell
  Dim shellWin As Object
  For Each shellWin In shellApp.Windows
    If shellWin.Name = "Internet Explorer" Then
      On Error Resume Next
      If InStr(1, shellWin.Document.Title, titleKeyWord) > 0 Then
        Set GotIE_ = Nothing
        Set GotIE_ = shellWin
        Exit For
      End If
      On Error GoTo 0
    End If
  Next
  If GotIE_ Is Nothing Then Exit Function
  Set getIEByTitle = GotIE_
  Set shellApp = Nothing
  Set shellWin = Nothing
End Function

Public Function getIEByURL( _
                  ByVal targetURLKey As String) As InternetExplorer
'URLのキーワードが一致するページを表示中のIEを取得するメソッド'
  Dim shellApp As New Shell
  Dim shellWin As Object
  For Each shellWin In shellApp.Windows
    If shellWin.Name = "Internet Explorer" Then
      On Error Resume Next
      If InStr(1, shellWin.Document.URL, targetURLKey) > 0 Then
        Set GotIE_ = shellWin
        Exit For
      End If
      On Error GoTo 0
    End If
  Next
  If GotIE_ Is Nothing Then Exit Function
  Set getIEByURL = GotIE_
  Set shellApp = Nothing
  Set shellWin = Nothing
End Function

Public Function isTargetPage( _
                  ByVal pageTitleKeyWord As String) As Boolean
'ページタイトルにキーワードを含んでいるか判定するメソッド'
  isTargetPage = True
  On Error Resume Next
  If InStr(1, Me.CurrentDocument.Title, pageTitleKeyWord) > 0 Then _
    Exit Function
  On Error GoTo 0
  isTargetPage = False
End Function

Public Function getElementByTagAndKeyWord( _
                  ByVal targetTagName As String, _
                  ByVal targetKeyWord As String) As Object
'タグ名とキーワードを要素内の文字列に持つ要素を取得するメソッド'
  Dim ret As Object
  Set ret = Nothing
  With Me.CurrentDocument
    Dim targetElement As Object
    For Each targetElement In .getElementsByTagName(targetTagName)
      If InStr(1, targetElement.outerHTML, targetKeyWord) > 0 Then
        Set ret = targetElement
        Exit For
      End If
    Next
  End With
  Set getElementByTagAndKeyWord = ret
End Function

Public Function getHTMLSource() As String
'表示中のHTMLドキュメントのソースを取得するメソッド'
  Dim ret As String
  ret = ""
  On Error Resume Next
  ret = GotIE_.Document.all(0).outerHTML
  On Error GoTo 0
  getHTMLSource = ret
End Function

Public Sub createSourceHTMLFile(ByVal fileFullName As String)
'表示中のページのHTMLソースをファイルとして出力するメソッド'
  Dim n As Long
  n = FreeFile(0)
  Open fileFullName For Output As n
    Print #n, Me.PageHTMLSource & vbCrLf
  Close #n
End Sub

Public Sub Quit()
'IEを終了するメソッド'
  GotIE_.Quit
End Sub

Private Sub waitFor(ByVal milliSeconds As Long)
'待ち時間設定用メソッド'
'内部処理専用'
  Dim startTime As Long
  startTime = GetTickCount
  Do While (GetTickCount - startTime) < milliSeconds
    DoEvents
    Call Sleep(1)
  Loop
End Sub

各メソッドの機能は、コード中のコメントをどうぞ。（なげやり）

使ってみる

WebAppクラスを、次のコードで利用してみる。

リスト２　標準モジュール

Public Sub disposable03()
  Dim webApp_ As New WebApp
  With webApp_
    '最初のページに移動する'
    Call .init("http://akashi-keirin.hatenablog.com/entry/2018/12/16/001606")
    '最初のページのHTMLソースを出力する'
    Call .createSourceHTMLFile(ThisWorkbook.Path & "\「マーカ部分を……」_src.html")
    '「検索」ボックスに「ち～んｗ」を入力する'
    Dim targetTextBox As HTMLInputElement
    On Error Resume Next
    Do
      Err.Clear
      Set targetTextBox = .getElementByTagAndKeyWord("input", "name=""q""")
      targetTextBox.Value = "ち～んｗ"
    Loop Until Err.Number = 0
    '検索実行ボタンをクリックする'
    Dim targetButton As HTMLInputButtonElement
    Set targetButton = .getElementByTagAndKeyWord("input", "value=""検索""")
    targetButton.Click
    Call WindowsAPI.waitFor(5000)
    'ページが取得できているかどうか試行錯誤する'
    Dim n As Long
    n = 1
    Do
      DoEvents
      Call WindowsAPI.waitFor(1000)
      If n > 2 Then _
        Call .getIEByTitle("ち～んｗ")
      Debug.Print "Wait " & n & " 回目：" & .CurrentDocument.Title
      n = n + 1
      If n > 5 Then .Quit: Exit Do
    Loop Until .isTargetPage("ち～んｗ")
  End With
  '移動後のページのHTMLソースを出力する'
  Call webApp_.createSourceHTMLFile( _
         ThisWorkbook.Path & "\「ち～んｗ」の検索結果_src.html")
  'メッセージを表示してすべてを終わらせる'
  Debug.Print "終了"
  webApp_.Quit
  Set webApp_ = Nothing
  Set targetTextBox = Nothing
  Set targetButton = Nothing
End Sub

それぞれのセクションで何をやっているのかは、コード中のコメントをどうぞ。（なげやり）