Internet Explorerのタブを切り替えるVBAマクロ

ホーム
Office関連, Excel, Word, PowerPoint
Internet Explorerのタブを切り替えるVBAマクロ

2016.11.18

Internet Explorerのタブを切り替えるVBAマクロ

前回の記事でInternet Explorerを操作するVBAマクロを紹介しましたが、ついでにURLを指定して、Internet Explorerのタブを切り替えるマクロも書いてみました。

※ 64ビット版Officeではコードを書きかえる必要があります。

'UIAutomationClient(UIAutomationCore.dll)要参照
Option Explicit

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 ShowWindow Lib "User32" ( _
  ByVal hWnd As Long, _
  ByVal nCmdShow As Long) As Long
Private Const SW_SHOWNORMAL = 1

Public Sub Sample()
  SelectIETab "weather.yahoo.co.jp"
End Sub

Private Sub SelectIETab(ByVal url As String)
'指定したURLのタブに切り替える
  Dim ie As Object
  Dim uiAuto As CUIAutomation
  Dim elmNavBar As IUIAutomationElement
  Dim elmTabs As IUIAutomationElement
  Dim aryTabs As IUIAutomationElementArray
  Dim ptnSelectionItem As IUIAutomationSelectionItemPattern
  Dim cnd As IUIAutomationCondition
  Dim hNavBar As Long, i As Long
  
  Set ie = GetActiveIE(url)
  If ie Is Nothing Then Exit Sub
  ShowWindow ie.hWnd, SW_SHOWNORMAL '最少化時を考慮してウィンドウを元に戻す
  hNavBar = FindWindowEx(ie.hWnd, 0, "WorkerW", vbNullString) 'ナビゲーション バー
  If hNavBar = 0 Then Exit Sub
  Set uiAuto = New CUIAutomation
  Set elmNavBar = uiAuto.ElementFromHandle(ByVal hNavBar)
  If elmNavBar Is Nothing Then Exit Sub
  Set elmTabs = GetElement(uiAuto, _
                           elmNavBar, _
                           UIA_NamePropertyId, _
                           "タブ行", _
                           UIA_TabControlTypeId)
  If elmTabs Is Nothing Then Exit Sub
  Set cnd = uiAuto.CreatePropertyCondition( _
              UIA_ControlTypePropertyId, _
              UIA_TabItemControlTypeId _
            )
  Set aryTabs = elmTabs.FindAll(TreeScope_Subtree, cnd)
  For i = 0 To aryTabs.Length - 1
    'LegacyIAccessible.DescriptionにURLが含まれているかを判断してタブ選択
    If InStr(aryTabs.GetElement(i).GetCurrentPropertyValue(UIA_LegacyIAccessibleDescriptionPropertyId), _
             ie.LocationURL) Then
      Set ptnSelectionItem = aryTabs.GetElement(i).GetCurrentPattern(UIA_SelectionItemPatternId)
      ptnSelectionItem.Select
      Exit For
    End If
  Next
End Sub

Private Function GetActiveIE(ByVal url As String) As Object
'URLを指定して起動中のIE取得
  Dim o As Object
  
  For Each o In GetObject("new:{9BA05972-F6A8-11CF-A442-00A0C90A8F39}") 'ShellWindows
    If LCase(TypeName(o)) = "iwebbrowser2" Then
      If LCase(TypeName(o.Document)) = "htmldocument" Then
        If o.LocationURL Like "*" & url & "*" Then
          Set GetActiveIE = o
          Exit For
        End If
      End If
    End If
  Next
End Function

Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0) As IUIAutomationElement
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition
   
  Set cndFirst = uiAuto.CreatePropertyCondition( _
                   propertyId, _
                   propertyValue _
                 )
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition( _
                      UIA_ControlTypePropertyId, _
                      ctrlType _
                    )
    Set cndFirst = uiAuto.CreateAndCondition( _
                     cndFirst, _
                     cndSecond _
                   )
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function

selectietab_01