カスタム検索
Office関連

 

トップページ > Office関連 > Office クリップボードをマクロで操作する(Office 2003)

 

Sponsored Links

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

コピー(切り取り)をしたデータを複数登録でき、好きなときに貼り付けることができる「Office クリップボード」機能。
今回はこの機能をマクロで操作する方法を紹介します(※ Office 2003専用(2007以降用はコチラ))。

Option Explicit

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

Private Const CHILDID_SELF = 0&
Private Const ROLE_SYSTEM_LIST = &H21
Private Const ROLE_SYSTEM_PROPERTYPAGE = &H26
Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B
Private Const ROLE_SYSTEM_WINDOW = &H9

Private Sub PasteOfficeClipboardItem(ByVal Num As Long)
'Officeクリップボードに登録されているアイテムを貼り付け
  Dim Acc As Office.IAccessible
  
  Set Acc = GetAccOfficeClipboardList
  If Acc Is Nothing Then Exit Sub
  If (Acc.accChildCount = 1) And (InStr(Acc.accName(1&), "クリップボードは空")) Then
    MsgBox "クリップボードは空です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  If Num > Acc.accChildCount Then
    MsgBox "指定した番号は無効です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  Acc.accDoDefaultAction Num
  Set Acc = Nothing
End Sub

Private Sub DoActionOfficeClipboard(ByVal AccObjName As String)
'Officeクリップボードコマンド実行
  Dim Acc As Office.IAccessible
  Dim Count As Long
  Dim i As Long
  
  Select Case AccObjName
    Case "すべて貼り付け", "すべてクリア"
    Case Else
      MsgBox "指定したコマンドには対応していません。" & vbCrLf & "「すべて貼り付け」か「すべてクリア」のどちらかを指定してください。", vbCritical + vbSystemModal
      Exit Sub
  End Select
  
  Application.CommandBars.FindControl(ID:=809).Execute
  Application.CommandBars("Task Pane").Visible = True
  DoEvents
  Set Acc = Application.CommandBars("Task Pane")
  Set Acc = GetAcc(Acc, "Collect and Paste 2.0", ROLE_SYSTEM_WINDOW)
  Set Acc = GetAcc(Acc, "Collect and Paste 2.0", ROLE_SYSTEM_PROPERTYPAGE)
  Count = Acc.accChildCount
  If Count > 0& Then
    For i = 0 To Count
      If (Acc.accName(i) = AccObjName) And (Acc.accRole(i) = ROLE_SYSTEM_PUSHBUTTON) Then
        Acc.accDoDefaultAction i
        Exit For
      End If
    Next
  End If
  Set Acc = Nothing
End Sub

Private Sub GetOfficeClipboardList(ByRef ItemList As Variant)
'Officeクリップボードリスト取得
  Dim Acc As Office.IAccessible
  Dim Count As Long
  Dim v() As Variant
  Dim i As Long
  
  Set Acc = GetAccOfficeClipboardList
  If Acc Is Nothing Then Exit Sub
  Count = Acc.accChildCount
  If (Count = 1) And (InStr(Acc.accName(1&), "クリップボードは空")) Then
    MsgBox "クリップボードは空です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  ReDim v(Count - 1)
  For i = 1 To Count
    v(i - 1) = Acc.accName(i)
  Next
  Set Acc = Nothing
  ItemList = v
End Sub

Private Function GetAccOfficeClipboardList() As Office.IAccessible
'Officeクリップボードリスト(Accessibleオブジェクト)取得
  Dim Acc As Office.IAccessible
  
  Application.CommandBars.FindControl(ID:=809).Execute
  Application.CommandBars("Task Pane").Visible = True
  DoEvents
  Set Acc = Application.CommandBars("Task Pane")
  Set Acc = GetAcc(Acc, "Collect and Paste 2.0", ROLE_SYSTEM_WINDOW)
  Set Acc = GetAcc(Acc, "Collect and Paste 2.0", ROLE_SYSTEM_PROPERTYPAGE)
  Set Acc = GetAcc(Acc, "クリップボード", ROLE_SYSTEM_LIST)
  Set GetAccOfficeClipboardList = Acc
  Set Acc = Nothing
End Function

Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
  Dim ReturnAcc As Office.IAccessible
  Dim ChildAcc As Office.IAccessible
  Dim List() As Variant
  Dim Count As Long
  Dim i As Long
  
  If (myAcc.accState(CHILDID_SELF) <> 32769) And _
     (myAcc.accName(CHILDID_SELF) = myAccName) And _
     (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
    Set ReturnAcc = myAcc
  Else
    Count = myAcc.accChildCount
    If Count > 0& Then
      ReDim List(Count - 1&)
      If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
        For i = LBound(List) To UBound(List)
          If TypeOf List(i) Is Office.IAccessible Then
            Set ChildAcc = List(i)
            Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
            If Not ReturnAcc Is Nothing Then Exit For
          End If
        Next
      End If
    End If
  End If
  Set GetAcc = ReturnAcc
End Function

 

Sponsored Links

 

上記プロシージャを利用すると、番号指定によるアイテムの貼り付けや「すべて貼り付け」「すべてクリア」コマンドの実行、Officeクリップボード内のアイテム内容の取得ができます(下記コード参照)。

Public Sub Sample01()
'Officeクリップボードに登録された2番目のアイテムを貼り付け
  PasteOfficeClipboardItem 2
End Sub

Public Sub Sample02()
  'DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
  DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
End Sub

Public Sub Sample03()
'Officeクリップボードに登録されているアイテムの内容を列挙
  Dim v As Variant
  Dim i As Long
  
  GetOfficeClipboardList v
  If IsEmpty(v) Then Exit Sub
  For i = LBound(v) To UBound(v)
    MsgBox "アイテム番号:" & i + 1 & vbTab & v(i), vbInformation + vbSystemModal
  Next
End Sub

トップページ > Office関連 > Office クリップボードをマクロで操作する(Office 2003)