VBA:Office 365更新后,用于清除Office剪贴板的代码不起作用

我有一个宏,可将rtf格式的word文档复制到Outlook电子邮件中,以发送给许多收件人。但是,由于这个原因,文本的副本也保存在剪贴板上,如果有很多收件人,代码也会崩溃。我使用下面的代码清除剪贴板,但是在Office 365更新后该代码不再起作用。我尝试将声明函数更改为包括“ Ptrsafe”,但仍无法运行。任何帮助将不胜感激。谢谢

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,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),vbTextCompare) = 0)
  ElseIf strCaption > "" Then
  found = (StrComp(GetWndText(hChild),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,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,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,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,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```


yangguangpuzhao1989 回答:VBA:Office 365更新后,用于清除Office剪贴板的代码不起作用

我们可以使用MsForms.DataObject清除剪贴板。下面的代码无需参考MsForms库即可创建一个。

Sub ClearClipBoard()
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText ""
        .PutInClipBoard
    End With
End Sub
本文链接:https://www.f2er.com/2927036.html

大家都在问