Windows 10

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.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.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.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」をキーワードにして検索実行 → 検索結果のスクリーンショットを撮る、といったことを行っています。

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

上記のようにWebDriverを使うことで、化石とも言える古い技術【VBScript】からでもMicrosoft Edgeを操作できることが分かりました。ただし、効率が良いとは言えませんので、実際に業務で利用するときはSeleniumの利用をお薦めします。

関連記事

関連記事

  1. Windows 10

    Microsoft EdgeのURL制限は2083文字なのか調べてみた。

    Internet Explorerで使用できるURLの長さに制限がある…

  2. Windows 10

    「ファイル名を指定して実行」からMicrosoft Edgeを起動する

    以前書いた記事で、Microsoft EdgeをVBScriptから起…

  3. VBScript

    実行中のアプリケーション一覧を出力するVBScript

    「VBS アプリ一覧 出力」というキーワード検索での訪問があったので、…

  4. Windows 10

    Microsoft Edgeのお気に入りをHTML形式でインポート・エクスポートする。

    以前当ブログでMicrosoft Edgeのお気に入りを編集する方法に…

  5. Windows 10

    WinAppDriver UI Recorderを試してみました。

    下記記事にある通り、「WinAppDriver UI Recorder…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP