Clearing office clipboard is not working after Office 365 update

Question

I have a macro that copies rtf format word document to outlook email for sending it to many recipients. However, due to this a copy of the text is also saved on the clipboard and the code crashes if many recipients are there. I was using the below code for clearing the clipboard but the code is no longer working after the office 365 update. I tried changing the declare functions to include 'Ptrsafe' but still not able to run it. Any help would be greatly appreciated. Thanks

Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
  ByVal hwnd As Long, ByVal dwId As Long, _
  riid As tGUID, ppvObject As Object) As Long

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

Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( _
  ByVal lpClassName As String, _
  ByVal lpWindowName As String) As Long

Declare Function GetParent Lib "User32" (ByVal hwnd As Long) As Long

Declare Function EnumChildWindows Lib "User32" (ByVal hwndParent _
  As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long

Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hwnd As Long, _
  ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
  ByVal hWnd2 As Long, ByVal lpClass As String, ByVal lpCaption As String) As Long

Const CHILDID_SELF = 0&
Const ROLE_PUSHBUTTON = &H2B&
Const WM_GETTEXT = &HD

Type tGUID
  lData1  As Long
  nData2  As Integer
  nData3  As Integer
  abytData4(0 To 7)  As Byte
End Type

Type AccObject
  objIA  As IAccessible
  lngChild  As Long
End Type


Dim lngChild  As Long
Dim strClass  As String
Dim strCaption  As String
'Using Active Accessibility to clear Office clipboard
'Assumption:
'this is running within Word or Excel as a macro, thus the global Application object is available
Sub ClearOfficeClipboard()
  Static accButton  As AccObject
  If accButton.objIA Is Nothing Then
  Dim fShown  As Boolean
  fShown = CommandBars("Office Clipboard").Visible  'Office 2013+ version
  If Not (fShown) Then
  CommandBars("Office Clipboard").Visible = True   'Office 2013+ version
  End If
  accButton = FindAccessibleChildInWindow(GetOfficeClipboardHwnd(Application), "Clear All", ROLE_PUSHBUTTON)
  End If
  If accButton.objIA Is Nothing Then
  MsgBox "Unable to locate the ""Clear All"" button!"
  Else
  accButton.objIA.accDoDefaultAction accButton.lngChild
  End If
  CommandBars("Office Clipboard").Visible = False
End Sub

'Retrieve window class name
Function GetWndClass(ByVal hwnd As Long) As String
  Dim buf As String
  Dim retval  As Long

  buf = Space(256)
  retval = GetClassName(hwnd, buf, 255)
  GetWndClass = Left(buf, retval)
End Function

'Retrieve window title
Function GetWndText(ByVal hwnd As Long) As String
  Dim buf  As String
  Dim retval  As Long

  buf = Space(256)
  retval = SendMessage(hwnd, WM_GETTEXT, 255, buf)
  GetWndText = Left(buf, InStr(1, buf, Chr(0)) - 1)
End Function

'The call back function used by EnumChildWindows
Function EnumChildWndProc(ByVal hChild As Long, ByVal lParam As Long) As Long
  Dim found  As Boolean

  EnumChildWndProc = -1
  If strClass > "" And strCaption > "" Then
  found = StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0 And _
  StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0
  ElseIf strClass > "" Then
  found = (StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0)
  ElseIf strCaption > "" Then
  found = (StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0)
  Else
  found = True
  End If

  If found Then
  lngChild = hChild
  EnumChildWndProc = 0
  Else
  EnumChildWndProc = -1
  End If
End Function

'Find the window handle of a child window based on its class and titie
Function FindChildWindow(ByVal hParent As Long, Optional cls As String = "", Optional title As String = "") As Long
  lngChild = 0
  strClass = cls
  strCaption = title
  EnumChildWindows hParent, AddressOf EnumChildWndProc, 0
  FindChildWindow = lngChild
End Function

'Retrieve the IAccessible interface from a window handle
'Reference:Jean Ross,Chapter 17: Accessibility in Visual Basic,Advanced Microsoft Visual Basic 6.0, 2nd Edition
Function IAccessibleFromHwnd(hwnd As Long) As IAccessible
  Dim oIA  As IAccessible
  Dim tg  As tGUID
  Dim lReturn  As Long

  ' Define the GUID for the IAccessible object
 ' {618736E0-3C3D-11CF-810C-00AA00389B71}

  With tg
  .lData1 = &H618736E0
  .nData2 = &H3C3D
  .nData3 = &H11CF
  .abytData4(0) = &H81
  .abytData4(1) = &HC
  .abytData4(2) = &H0
  .abytData4(3) = &HAA
  .abytData4(4) = &H0
  .abytData4(5) = &H38
  .abytData4(6) = &H9B
  .abytData4(7) = &H71
  End With
  ' Retrieve the IAccessible object for the form
 lReturn = AccessibleObjectFromWindow(hwnd, 0, tg, oIA)
  Set IAccessibleFromHwnd = oIA
End Function

'Recursively looking for a child with specified accName and accRole in the accessibility tree
Function FindAccessibleChild(oParent As IAccessible, strName As String, lngRole As Long) As AccObject
  Dim lHowMany  As Long
  Dim avKids()  As Variant
  Dim lGotHowMany As Long, i  As Integer
  Dim oChild  As IAccessible
  FindAccessibleChild.lngChild = CHILDID_SELF
  If oParent.accChildCount = 0 Then
  Set FindAccessibleChild.objIA = Nothing
  Exit Function
  End If
  lHowMany = oParent.accChildCount
  ReDim avKids(lHowMany - 1) As Variant
  lGotHowMany = 0
  If AccessibleChildren(oParent, 0, lHowMany, avKids(0), lGotHowMany) <> 0 Then
  MsgBox "Error retrieving accessible children!"
  Set FindAccessibleChild.objIA = Nothing
  Exit Function
  End If

  'To do: the approach described in http://msdn.microsoft.com/msdnmag/issues/0400/aaccess/default.aspx
 ' are probably better and more reliable
 On Error Resume Next
  For i = 0 To lGotHowMany - 1
  If IsObject(avKids(i)) Then
  If StrComp(avKids(i).accName, strName) = 0 And avKids(i).accRole = lngRole Then
  Set FindAccessibleChild.objIA = avKids(i)
  Exit For
  Else
  Set oChild = avKids(i)
  FindAccessibleChild = FindAccessibleChild(oChild, strName, lngRole)
  If Not FindAccessibleChild.objIA Is Nothing Then
  Exit For
  End If
  End If
  Else
  If StrComp(oParent.accName(avKids(i)), strName) = 0 And oParent.accRole(avKids(i)) = lngRole Then
  Set FindAccessibleChild.objIA = oParent
  FindAccessibleChild.lngChild = avKids(i)
  Exit For
  End If
  End If
  Next i
End Function

Function FindAccessibleChildInWindow(hwndParent As Long, strName As String, lngRole As Long) As AccObject
  Dim oParent  As IAccessible
  Set oParent = IAccessibleFromHwnd(hwndParent)
  If oParent Is Nothing Then
  Set FindAccessibleChildInWindow.objIA = Nothing
  Else
  FindAccessibleChildInWindow = FindAccessibleChild(oParent, strName, lngRole)
  End If
End Function

'Retrieve the window handle of the task pane
Function GetOfficeTaskPaneHwnd(app As Object) As Long
  GetOfficeTaskPaneHwnd = FindChildWindow(app.hwnd, _
  "MsoCommandBar", Application.CommandBars("Task Pane").NameLocal)
End Function

'Retrieve the window handle of the clipboard child window inside task pane
'The window title of the clipboard window seems to be language independent,
'making it a better start point to searching our UI element than the task pane window
Function GetOfficeClipboardHwnd(app As Object) As Long
  GetOfficeClipboardHwnd = FindChildWindow(app.hwnd, , "Collect and Paste 2.0")
End Function```

I’m using editor to copy rtf mail from word to outlook. It makes them save a copy on clipboard. The above code used to clear the Office clipboard but it no longer works on office 365 — Abhishek, Dec 14 '19 at 14:09

score 2 · Answer 1 · answered Dec 14 '19 at 14:29

2

We can clear the clipboard using a MsForms.DataObject. The code below creates one without the need to reference the MsForms library.

Sub ClearClipBoard()
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText ""
        .PutInClipBoard
    End With
End Sub

answered Dec 14 '19 at 14:29

TinMan

6,624
2
10
20

The above code runs without any error but doesn't clear the office clipboard. Thanks – Abhishek Dec 15 '19 at 14:58
Have you tried @michaelf answer to [Excel 2013 64-bit VBA: Clipboard API doesn't work](https://stackoverflow.com/a/35512118/9912714). It both 32 and 64 bit versions of the WinAPI calls. If that doesn't work I would create a document with one word "Confidential" and copy it to to the Clipboard the same way you copy the current document. – TinMan Dec 16 '19 at 07:33

score 0 · Answer 2 · edited Apr 22 '23 at 18:03

Try through the UI Automation Client library with the following code. It worked for me (Win 10, Office 2021).

Dim MyElement As UIAutomationClient.IUIAutomationElement
Dim MyElement1 As UIAutomationClient.IUIAutomationElement

Public Enum oConditions
   eUIA_NamePropertyId
   eUIA_AutomationIdPropertyId
   eUIA_ClassNamePropertyId
   eUIA_LocalizedControlTypePropertyId
End Enum


Public Sub ClearOfficeClipboard()

'Must Enable UIAutomationClient library in the References

Dim AppObj As UIAutomationClient.IUIAutomationElement
Dim oInvokePattern As UIAutomationClient.IUIAutomationInvokePattern
Dim oAutomation As New CUIAutomation ' the UI Automation API\
Dim oPattern As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern

Set AppObj = WalkEnabledElements(Application.Caption)

Set MyElement = AppObj.FindFirst(TreeScope_Children,                 
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "EXCEL2"))

Set MyElement1 = MyElement.FindFirst(TreeScope_Children,         
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "MsoCommandBar"))

Set MyElement = MyElement1.FindFirst(TreeScope_Children, 
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "MsoWorkPane"))

Set MyElement1 = MyElement.FindFirst(TreeScope_Children, 
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "NUIPane"))

Set MyElement = MyElement1.FindFirst(TreeScope_Children, 
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "NetUIHWNDElement"))

Set MyElement1 = MyElement.FindFirst(TreeScope_Children, 
PropCondition(oAutomation, eUIA_ClassNamePropertyId, "NetUInetpane"))

Set MyElement = MyElement1.FindFirst(TreeScope_Children, 
PropCondition(oAutomation, eUIA_NamePropertyId, "Clear All"))

Set oInvokePattern = MyElement.GetCurrentPattern(UIAutomationClient.UIA_InvokePatternId)
oInvokePattern.Invoke

End Sub

Function PropCondition(UiAutomation As CUIAutomation, Prop As oConditions, Requirement As String) As UIAutomationClient.IUIAutomationCondition
    Select Case Prop
    Case 0
        Set PropCondition = UiAutomation.CreatePropertyCondition(UIAutomationClient.UIA_NamePropertyId, Requirement)
    Case 1
        Set PropCondition = UiAutomation.CreatePropertyCondition(UIAutomationClient.UIA_AutomationIdPropertyId, Requirement)
    Case 2
        Set PropCondition = UiAutomation.CreatePropertyCondition(UIAutomationClient.UIA_ClassNamePropertyId, Requirement)
    Case 3
        Set PropCondition = UiAutomation.CreatePropertyCondition(UIAutomationClient.UIA_LocalizedControlTypePropertyId, Requirement)
    End Select
End Function

Public Function WalkEnabledElements(strWindowName As String) As UIAutomationClient.IUIAutomationElement
    Dim oAutomation As New CUIAutomation
    Dim condition1 As UIAutomationClient.IUIAutomationCondition
    Dim condition2 As UIAutomationClient.IUIAutomationCondition
    Dim walker As UIAutomationClient.IUIAutomationTreeWalker
    Dim element As UIAutomationClient.IUIAutomationElement

    Set walker = oAutomation.ControlViewWalker
    Set element = walker.GetFirstChildElement(oAutomation.GetRootElement)

    Do While Not element Is Nothing
       ' Debug.Print element.CurrentName
        If InStr(1, element.CurrentName, strWindowName) > 0 Then
            Set WalkEnabledElements = element
            Exit Function
        End If
        Set element = walker.GetNextSiblingElement(element)
    Loop
End Function

Clearing office clipboard is not working after Office 365 update

2 Answers2

Linked