Office関連

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

上図の通り、Windows 10 + Internet Explorer 11環境でも動作しましたが、あまり出番はなさそうなマクロです。

関連Webページ

関連記事

  1. Office アドイン

    Office 2016で進化したOffice アドイン

    今日OfficeDevを眺めていて気が付いたのが「OfficeJS S…

  2. Office関連

    Google翻訳で文字列を翻訳するマクロ

    ※ 2016/2 時点では下記の方法はもう使用できなくなっています。V…

  3. Office関連

    「あのコマンドどこだっけ? for Office 2013」の紹介

    Word MVPの新田さんのブログでも紹介していただいている自作フリー…

  4. アイコン一覧

    Office 365アイコン(imageMso)一覧(A)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

  5. Office関連

    「カレンダーから日付入力」をUserFormに移植してみました。

    前回の記事では、Office 用アプリ「カレンダーから日付入力」と同様…

コメント

  • コメント (0)

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

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP