Microsoft Edgeを操作するVBScript

ホーム
Windows 10, Windows関連, VBScript, Microsoft Edge
Microsoft Edgeを操作するVBScript

2015.08.17

Microsoft Edgeを操作するVBScript

「Microsoft Edgeを操作するVBAマクロ(WebDriver編)」でも書いていますが、Edgeを外部から操作する方法として「WebDriver」が用意されています。

Microsoft Edge Dev Blogの記事にはC#のサンプルコードが記載されていますが、仕組みとしてはWebDriver Server(localhost)にJSONを投げれば良いだけなので、言語は何でも構いません。cURL + バッチ(DOS)でもEdgeを操作することが可能です。

そこで今回はEdgeを外部から操作するVBScriptを紹介します。

検証環境

Windows 10 Pro x86/x64
Microsoft Edge 20.10240.16384.0
WebDriver 1.0

Microsoft Edgeを操作するVBScript

※ 下記コードの動作には「WebDriver」が必要となります。事前にインストールしておいてください。

Option Explicit

Private http
Private doc
Private Const WebDriverFileName = "MicrosoftWebDriver.exe"
Private Const URI = "http://localhost:17556/"
Private Const CSIDL_PROGRAM_FILESX86 = 42

Set http = CreateObject("MSXML2.XMLHTTP")
Set doc = CreateObject("htmlfile")
Call AutomateMicrosoftEdge

Public Sub AutomateMicrosoftEdge()
'Microsoft Edge Automation using WebDriver
  Dim proc
  Dim sid, eid
  Dim b64
  Dim WebDriverFilePath
  
  'Run the 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 & " --port=17556")
  End If
  
  sid = StartSession()
  If sid = "" Then Exit Sub
  NavigateToURL sid, "https://www.bing.com/"
  WScript.Sleep 1000
  eid = FindElement(sid, "id", "sb_form_q")
  If eid = "" Then Exit Sub
  SendKeysElement sid, eid, "Microsoft MVP"
  eid = FindElement(sid, "id", "sb_form_go")
  If eid = "" Then Exit Sub
  ClickElement sid, eid
  WScript.Sleep 2000
  b64 = TakeScreenshot(sid)
  If b64 = "" Then Exit Sub
  DecodeBase64 b64, GetScriptFolderPath() & "Screenshot.png"
  EndSession sid
  If Not proc Is Nothing Then proc.Terminate 'Terminate Microsoft WebDriver Server
  
  MsgBox "done.", vbInformation + vbSystemModal
End Sub

Private Function StartSession()
'return sessionId
  Dim ret
  Dim json
  Dim elm
  
  On Error Resume Next
  With http
    .Open "POST", URI & "session", False
    .send "{""desiredCapabilities"": {}, ""requiredCapabilities"": {}}"
    Select Case .Status
      Case 200
        json = "(" & .responseText & ")"
        Set elm = doc.createElement("span")
        elm.setAttribute "id", "result"
        doc.body.appendChild elm
        doc.parentWindow.execScript _
          "document.getElementById('result').innerText=eval(" & json & ").sessionId;"
        If LCase(elm.innerText) = "null" Then
          ret = ""
        Else
          ret = elm.innerText
        End If
        doc.RemoveChild elm
    End Select
  End With
  On Error GoTo 0
  StartSession = ret
End Function

Private Sub NavigateToURL(ByVal sessionId, ByVal URL)
  On Error Resume Next
  With http
    .Open "POST", URI & "session/" & sessionId & "/url", False
    .send "{""url"": """ & URL & """}"
  End With
  On Error GoTo 0
End Sub

Private Function FindElement(ByVal sessionId, ByVal using, ByVal elmValue)
'return elementId
  Dim ret
  Dim json
  Dim elm
  
  On Error Resume Next
  With http
    .Open "POST", URI & "session/" & sessionId & "/element", False
    .send "{""using"": """ & using & """, ""value"": """ & elmValue & """}"
    Select Case .Status
      Case 200
        json = "(" & .responseText & ")"
        Set elm = doc.createElement("span")
        elm.setAttribute "id", "result"
        doc.body.appendChild elm
        doc.parentWindow.execScript _
          "document.getElementById('result').innerText=eval(" & json & ").value.ELEMENT;"
        If LCase(elm.innerText) = "null" Then
          ret = ""
        Else
          ret = elm.innerText
        End If
        doc.RemoveChild elm
    End Select
  End With
  On Error GoTo 0
  FindElement = ret
End Function

Private Sub SendKeysElement(ByVal sessionId, ByVal elementId, ByVal elmValue)
  On Error Resume Next
  With http
    .Open "POST", URI & "session/" & sessionId & "/element/" & elementId & "/value", False
    .send "{""value"":[""" & elmValue & """]}"
  End With
  On Error GoTo 0
End Sub

Private Sub ClickElement(ByVal sessionId, ByVal elementId)
  On Error Resume Next
  With http
    .Open "POST", URI & "session/" & sessionId & "/element/" & elementId & "/click", False
    .send
  End With
  On Error GoTo 0
End Sub

Private Function TakeScreenshot(ByVal sessionId)
'return screenshot as a base64 encoded PNG
  Dim ret
  Dim json
  Dim elm
  
  On Error Resume Next
  With http
    .Open "GET", URI & "session/" & sessionId & "/screenshot", False
    .send
    Select Case .Status
      Case 200
        json = "(" & .responseText & ")"
        Set elm = doc.createElement("span")
        elm.setAttribute "id", "result"
        doc.body.appendChild elm
        doc.parentWindow.execScript _
          "document.getElementById('result').innerText=eval(" & json & ").value;"
        If LCase(elm.innerText) = "null" Then
          ret = ""
        Else
          ret = elm.innerText
        End If
        doc.RemoveChild elm
    End Select
  End With
  On Error GoTo 0
  TakeScreenshot = ret
End Function

Private Sub EndSession(ByVal sessionId)
  On Error Resume Next
  With http
    .Open "DELETE", URI & "session/" & sessionId, False
    .send
  End With
  On Error GoTo 0
End Sub

Private Sub DecodeBase64(ByVal base64, ByVal filePath)
'decode a base64 string
  Dim elm
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  On Error Resume Next
  Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
  elm.DataType = "bin.base64"
  elm.Text = base64
  With CreateObject("ADODB.Stream")
    .Type = adTypeBinary
    .Open
    .Write elm.nodeTypedValue
    .SaveToFile filePath, adSaveCreateOverWrite
    .Close
  End With
  On Error GoTo 0
End Sub

Private Function GetScriptFolderPath()
  Dim ret
  
  With CreateObject("Scripting.FileSystemObject")
    ret = .GetParentFolderName(WScript.ScriptFullName)
  End With
  If Right(ret, 1) <> ChrW(92) Then ret = ret & ChrW(92)
  GetScriptFolderPath = ret
End Function

スクリプトの動作は「Microsoft Edgeを操作するVBAマクロ(WebDriver編)」とほぼ同じで、EdgeでBingを開く → 「Microsoft MVP」をキーワードにして検索実行 → 検索結果のスクリーンショットを撮る、といったことを行っています。

実際にスクリプトを実行した際の動画をアップしたので、どのような動きをするのかは下記動画をご参照ください。