Office クリップボードをマクロで操作する(MSAA)

ホーム
Excel, Office関連, Word, PowerPoint
Office クリップボードをマクロで操作する(MSAA)

2017.12.20

Office クリップボードをマクロで操作する(MSAA)

MSDNフォーラムに質問がありましたが、Office クリップボードをマクロで操作するのは一定の需要があるので、以前書いたマクロ(下記参照)を書き直してみました。

Office クリップボードをマクロで操作する(Office 2003)
http://www.ka-net.org/office/of55.html
Office クリップボードをマクロで操作する(Office 2007以降)
http://www.ka-net.org/office/of56.html

Option Explicit

Private Declare Function AccessibleChildren Lib "oleacc" ( _
  ByVal paccContainer As IAccessible, _
  ByVal iChildStart As Long, _
  ByVal cChildren As Long, _
  ByRef rgvarChildren As Any, _
  ByRef pcObtained As Long) As Long

Public Sub Sample()
  'DoActionOfficeClipboard "すべて貼り付け"
  DoActionOfficeClipboard "すべてクリア"
End Sub

Private Sub DoActionOfficeClipboard(ByVal ButtonName As String)
'Officeクリップボードコマンド実行
  Dim accClipboard As IAccessible
  Dim accCollectPage As IAccessible
  Dim accButton As IAccessible
  Dim tmp As Boolean
  Dim i As Long
  Const CommandBarName = "Office Clipboard"
  Const ROLE_SYSTEM_PROPERTYPAGE = &H26
  Const ROLE_SYSTEM_PUSHBUTTON = &H2B
  Const CHILDID_SELF = &H0&
  
  Select Case ButtonName
    Case "すべて貼り付け", "すべてクリア"
    Case Else
      MsgBox "指定したコマンドには対応していません。" & vbNewLine & _
             "「すべて貼り付け」か「すべてクリア」のどちらかを指定してください。", _
             vbCritical + vbSystemModal
      Exit Sub
  End Select
  
  With Application.CommandBars(CommandBarName)
    tmp = .Visible
    .Visible = True
  End With
  DoEvents
  Set accClipboard = Application.CommandBars(CommandBarName)
  If accClipboard Is Nothing Then GoTo Fin
  
  '旧バージョンOffice対応
  Set accCollectPage = GetAccessibleObject(accClipboard, _
                                           "Collect and Paste 2.0", _
                                           ROLE_SYSTEM_PROPERTYPAGE)
  If Not accCollectPage Is Nothing Then
    For i = 1 To accCollectPage.accChildCount
      If (accCollectPage.accName(i&) = ButtonName) And _
         (accCollectPage.accRole(i&) = ROLE_SYSTEM_PUSHBUTTON) Then
        accCollectPage.accDoDefaultAction i&
        Exit For
      End If
    Next
  Else
    '新バージョンOffice対応
    Set accCollectPage = GetAccessibleObject(accClipboard, _
                                           "クリップボード", _
                                           ROLE_SYSTEM_PROPERTYPAGE)
    If Not accCollectPage Is Nothing Then
      Set accButton = GetAccessibleObject(accCollectPage, _
                                          ButtonName, _
                                          ROLE_SYSTEM_PUSHBUTTON)
      If accButton Is Nothing Then GoTo Fin
      accButton.accDoDefaultAction CHILDID_SELF
    Else
      MsgBox "クリップボードウィンドウが見つかりませんでした。" & vbNewLine & _
             "処理を中止します｡ ", vbCritical + vbSystemModal
    End If
  End If
Fin:
  Application.CommandBars(CommandBarName).Visible = tmp
End Sub

Private Function GetAccessibleObject(ByVal SrcAccObj As IAccessible, _
                                     ByVal TgtAccName As String, _
                                     ByVal TgtAccRole As Long) As IAccessible
  Dim ret As IAccessible
  Dim list() As Variant
  Dim cnt As Long, i As Long
  Const CHILDID_SELF = &H0&
  
  Set ret = Nothing '初期化
  If (SrcAccObj.accName(CHILDID_SELF) = TgtAccName) And _
     (SrcAccObj.accRole(CHILDID_SELF) = TgtAccRole) Then
    Set ret = SrcAccObj
  Else
    cnt = SrcAccObj.accChildCount
    If cnt > 0 Then
      ReDim list(cnt - 1)
      If AccessibleChildren(SrcAccObj, 0, cnt, list(0), cnt) = 0 Then
        For i = LBound(list) To UBound(list)
          If TypeOf list(i) Is IAccessible Then
            Set ret = GetAccessibleObject(list(i), TgtAccName, TgtAccRole)
            If Not ret Is Nothing Then Exit For
          End If
        Next
      End If
    End If
  End If
  Set GetAccessibleObject = ret
End Function

以前書いたコードは、OfficeやOSのバージョンが変わると動作しませんでしたが、今回はバージョンの差異も一応考慮しています(Excel 2007,2010,2016で確認)。

とはいえ、次期バージョンで動作するかは分かりませんし、Office クリップボードを操作するためだけに処理を複雑にするのも問題ですので、この機能がどうしても必要でない場合は、実装しない方向で調整しても良いのではないかと思います。