Microsoft Edgeを操作するVBAマクロ(WebDriver編)

ホーム
Office関連, Excel, Windows 10, Windows関連, Word, PowerPoint, Microsoft Edge, Selenium
Microsoft Edgeを操作するVBAマクロ(WebDriver編)

Office関連

2015.08.7

Microsoft Edgeを操作するVBAマクロ(WebDriver編)

Microsoft Edge Dev Blogに「Bringing automated testing to Microsoft Edge through WebDriver」といった記事がありました。

この記事によると「Microsoft WebDriver」を使えば、外部プログラムからMicrosoft Edgeを操作することができる、とのこと。

実際にSeleniumを使ってEdgeを操作するC#のサンプルコードも載っているのですが、下図を見る限りMicrosoft WebDriver ServerにJSONを渡せば良いだけで、Seleniumは必須では無さそうです。

http://blogs.windows.com/msedgedev/2015/07/23/bringing-automated-testing-to-microsoft-edge-through-webdriver/ より

となるとつまり、“Microsoft WebDriverを使えばVBAからでもEdgeを操作できる！”ということ。

これはもう試すしかない！！
さっそくやってみることにしました。

検証環境

Windows 10 Pro 64ビット版
Office 2013 32ビット版
Microsoft Edge 20.10240.16384.0

Microsoft WebDriverのインストール

「Download Microsoft WebDriver from Official Microsoft Download Center」からMicrosoftWebDriver.msiファイルをダウンロードします。
手順1.でダウンロードした MicrosoftWebDriver.msi ファイルを実行し、指示に従ってインストール作業を進めます。

「Completed thr Microsoft Web Driver Setup Wizard」画面が表示されたら「Finish」ボタンをクリックして作業終了です。

Microsoft WebDriverのインストールが終わると、Program Files (x86)フォルダ(32ビット版の場合はProgram Filesフォルダ)に「Microsoft Web Driver」フォルダが作成され、その中に「MicrosoftWebDriver.exe」ファイルが作成されます。

Microsoft Edgeを操作するVBAマクロ

いよいよEdgeを操作するVBAコードです。
下記コードでは、

Microsoft WebDriver Server(localhost)を起動します。
セッションを開始します。
Yahoo! JAPANにページ移動し、「@kinuasa」をキーワードに検索を行います。
検索結果のスクリーンショットを保存(Base64文字列をデコード)します。
セッションを終了します。
Microsoft WebDriver Serverを終了します。

といったことを行っています。
WebDriver Serverに渡すリクエストは下記Webページを参考にしました。
特にTest Driveはレスポンスも確認しやすいので、とても参考になりました。

Test Drive – WebDriver
http://dev.modern.ie/testdrive/demos/webdriver/
WebDriver Status
http://dev.modern.ie/platform/status/webdriver/details/

※ 下記コードではJSONのパースにScriptControlを使用しているため、64ビット版のOfficeでは動作しません。

Option Explicit

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

Public Sub AutomateMicrosoftEdge()
'Microsoft WebDriverを使ってEdgeを操作する
  Dim sc As Object
  Dim proc As Object
  Dim json As Object, ary As Object
  Dim jstr As String
  Dim sid As Variant, eid As Variant, b64 As Variant
  Dim eval
  Dim WebDriverFilePath As String
  Const WebDriverFileName As String = "MicrosoftWebDriver.exe"
  Const URI As String = "http://localhost:17556/"
  Const CSIDL_PROGRAM_FILESX86 = 42
  
  'Microsoft WebDriver Server実行
  WebDriverFilePath = CreateObject("Shell.Application").Namespace(CSIDL_PROGRAM_FILESX86).Self.Path
  WebDriverFilePath = WebDriverFilePath & "\Microsoft Web Driver\" & WebDriverFileName
  If CreateObject("Scripting.FileSystemObject") _
     .FileExists(WebDriverFilePath) = False Then Exit Sub
  If CreateObject("WbemScripting.SWbemLocator").ConnectServer.ExecQuery _
     ("Select * From Win32_Process Where Name = '" & WebDriverFileName & "'").Count < 1 Then
    Set proc = CreateObject("WScript.Shell").Exec(WebDriverFilePath)
  End If
  
  Set sc = CreateObject("ScriptControl")
  sc.Language = "JScript"
  With CreateObject("MSXML2.XMLHTTP")
    'セッション開始(sessionId取得)
    .Open "POST", URI & "session", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send "{""desiredCapabilities"": {}, ""requiredCapabilities"": {}}"
    If .Status <> 200 Then GoTo Err
    jstr = "(" & .responseText & ")"
    Set json = sc.CodeObject.eval(jstr)
    sid = VBA.CallByName(json, "sessionId", VbGet)
    If IsNull(sid) = True Then GoTo Err
    
    'Yahoo! JAPANにページ移動
    .Open "POST", URI & "session/" & sid & "/url", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send "{""url"": ""http://www.yahoo.co.jp/""}"
    If .Status <> 200 Then GoTo Err
    
    '検索ボックス(srchtxt)取得
    .Open "POST", URI & "session/" & sid & "/element", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send "{""using"": ""id"", ""value"": ""srchtxt""}"
    If .Status <> 200 Then GoTo Err
    jstr = "(" & .responseText & ")"
    Set json = sc.CodeObject.eval(jstr)
    Set ary = VBA.CallByName(json, "value", VbGet)
    eid = VBA.CallByName(ary, "ELEMENT", VbGet)
    If IsNull(eid) = True Then GoTo Err
    
    '検索ボックスに文字列送信(Send Keys)
    .Open "POST", URI & "session/" & sid & "/element/" & eid & "/value", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send "{""value"":[""@kinuasa""]}"
    If .Status <> 200 Then GoTo Err
    
    '検索ボタン(srchbtn)取得
    .Open "POST", URI & "session/" & sid & "/element", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send "{""using"": ""id"", ""value"": ""srchbtn""}"
    If .Status <> 200 Then GoTo Err
    jstr = "(" & .responseText & ")"
    Set json = sc.CodeObject.eval(jstr)
    Set ary = VBA.CallByName(json, "value", VbGet)
    eid = VBA.CallByName(ary, "ELEMENT", VbGet)
    If IsNull(eid) = True Then GoTo Err
    
    '検索ボタンクリック
    .Open "POST", URI & "session/" & sid & "/element/" & eid & "/click", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send
    If .Status <> 200 Then GoTo Err
    
    'スクリーンショット取得
    Sleep 3000 '表示待ち
    .Open "GET", URI & "session/" & sid & "/screenshot", False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send
    If .Status <> 200 Then GoTo Err
    jstr = "(" & .responseText & ")"
    Set json = sc.CodeObject.eval(jstr)
    b64 = VBA.CallByName(json, "value", VbGet)
    If IsNull(b64) = True Then GoTo Err
    DecodeBase64 b64, ActiveWorkbook.Path & "\ScreenShot.png"
    
    'セッション終了
    .Open "DELETE", URI & "session/" & sid, False
    .setRequestHeader "Content-Type", "text/plain; charset=UTF-8"
    .send
    If .Status <> 200 Then GoTo Err
  End With
  
  If Not proc Is Nothing Then proc.Terminate 'Microsoft WebDriver Server終了
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
  Exit Sub
Err:
  MsgBox "処理が失敗しました。", vbExclamation + vbSystemModal
End Sub

Private Function DecodeBase64(ByVal Base64Str As String, ByVal FilePath As String) As Long
'ファイルをBase64デコード
  Dim elm As Object
  Dim ret As Long
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  ret = -1 '初期化
  On Error Resume Next
  Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
  elm.DataType = "bin.base64"
  elm.Text = Base64Str
  With CreateObject("ADODB.Stream")
    .Type = adTypeBinary
    .Open
    .Write elm.nodeTypedValue
    .SaveToFile FilePath, adSaveCreateOverWrite
    .Close
  End With
  If Err.Number <> 0 Then ret = 0
  On Error GoTo 0
  DecodeBase64 = ret
End Function