Windows 10

【2017年1月版】Microsoft Edgeを操作するVBAマクロ(DOM編)

Microsoft Edge VBA 操作」こういったキーワード検索での、下記記事へのアクセスが結構あります。

Edge内にある「Internet Explorer_Server」クラスのウィンドウからIHTMLDocument経由で無理やりDOM操作するマクロですが、このコードを書いたのは2015年の8月です。

今は2017年、Windows 10も何度もバージョンアップを重ね、さすがにもうこのコードも動かないだろうと思って、久々にマクロを実行してみたところ・・・。

動きませんでした!

それはそうです。
Edgeだって改良され、ウィンドウの構造だって変わっているはずです。
Spy++で確認してみても、やはりEdgeの下に「Internet Explorer_Server」クラスのウィンドウは見つかりません。

「あー、やっぱりこんな無理やりなコードは動かなくなるよなー!そりゃ当然だよ」と思っていたところ、ふと下の方のウィンドウを見ると・・・。

有りました!
TabWindowClass」クラスのウィンドウの下に「Internet Explorer_Server」クラスのウィンドウが!!

プロセスIDからプロセスを確認してみると、「Microsoft Edge」となっています。

未だにEdgeはInternet Explorer_Serverを持っているのか!
なら先のコードはまだ動くんじゃないか!?

・・・というわけで修正したのが下記のコードです。

Option Explicit

Private Type UUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As Any, ByVal wParam As Long, ppvObject As Object) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SMTO_ABORTIFHUNG = &H2

Public Sub Sample_EdgeDOM()
'Microsoft EdgeをDOM操作(64ビット版Excelではコード要変更)
'http://www.mvps.org/emorcillo/en/code/vb6/iedom.shtml 参照
'
'※下記環境で動作確認
'Microsoft Windows 10 Pro Insider Preview バージョン:10.0.15019 ビルド 15019
'Microsoft Edge 40.15019.1000.0
'Microsoft Excel 2016 MSO (16.0.7668.7078) 32 ビット

  Dim hEdge As Long
  Dim hIES As Long
  Dim msg As Long
  Dim res As Long
  Dim d As Object
  Dim IID_IHTMLDocument2 As UUID
  
  'Edge起動
  CreateObject("Shell.Application").ShellExecute "microsoft-edge:http://www.yahoo.co.jp/"
  Sleep 2000
  
  'TabWindowClassウィンドウ取得
  hEdge = FindWindowEx(0, 0, "TabWindowClass", vbNullString)
  If hEdge = 0 Then Exit Sub
  
  'Internet Explorer_Serverウィンドウ取得
  hIES = FindWindowEx(hEdge, 0, "Internet Explorer_Server", vbNullString)
  If hIES = 0 Then Exit Sub
  
  'IHTMLDocument2取得
  msg = RegisterWindowMessage("WM_HTML_GETOBJECT")
  SendMessageTimeout hIES, msg, 0, 0, SMTO_ABORTIFHUNG, 1000, res
  If res Then
    With IID_IHTMLDocument2
      .Data1 = &H332C4425
      .Data2 = &H26CB
      .Data3 = &H11D0
      .Data4(0) = &HB4
      .Data4(1) = &H83
      .Data4(2) = &H0
      .Data4(3) = &HC0
      .Data4(4) = &H4F
      .Data4(5) = &HD9
      .Data4(6) = &H1
      .Data4(7) = &H19
    End With
    If ObjectFromLresult(res, IID_IHTMLDocument2, 0, d) = 0 Then
      'DOM操作
      d.getElementById("srchtxt").Value = "初心者備忘録ブログ"
      d.getElementById("srchbtn").Click
      While LCase(d.ReadyState) <> "complete"
        Sleep 100
      Wend
      MsgBox d.Title, vbInformation + vbSystemModal
    End If
  End If
End Sub

上記コードを実行すると、何の問題もなく、意図した通りにマクロが実行されます。

コード中にコメントで書いている通り、実行環境は下記の通りで、この記事を書いている2017年1月時点では最新の環境です。

  1. Microsoft Windows 10 Pro Insider Preview バージョン:10.0.15019 ビルド 15019
  2. Microsoft Edge 40.15019.1000.0
  3. Microsoft Excel 2016 MSO (16.0.7668.7078) 32 ビット

まさか未だにこんなやり方が通用するとは・・・。
Edge恐るべし、です。

※ 動くといっても上記方法はMicrosoftが推奨している方法ではありません。いつ使えなくなるかも分かりませんので、Edge操作の自動化を行いたい場合には、正式にサポートされている「WebDriver」を使うことをお薦めします。


2017/2/1 追記:
Edgeのプロセスからウィンドウを探すコードも書いてみました。

関連記事

  1. Office関連

    Excel 2016でマップグラフを作成する。

    12月6日、Office Insider向けに、Office 2016…

  2. Office アドイン

    [Office用アプリ]アプリ審査を通過するためのポイント

    前回の記事で、Seller Dashboard(販売者ダッシュボード)…

  3. Office関連

    選択している行の高さを増やすExcelマクロ

    Excelの表を印刷しようとしたとき、ビミョーに文字が切れていてイラッ…

コメント

  • コメント (1)

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

    • 中松拓也
    • 2018年 11月 11日

    edgeのvbaについて教えていただきたいのですが、可能でしょうか?
    よろしくお願いします

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP