クラスにしてしまったのでぶちまけておく
職場のクソ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
それぞれのセクションで何をやっているのかは、コード中のコメントをどうぞ。（なげやり）
おわりに
ひとまず、これだけの機能があれば、うちの職場のクソWebアプリには圧勝できる。
