Code:
' The main source of this coding is API guru Jaafar Tribak. As far as I can tell this big coding was something of a standard until at least the end of the last century. Possibly after that somne smaller ones may have started appearing
' Rory http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246770#p246770
' Don un CK76 https://www.excelforum.com/excel-programming-vba-macros/1217178-clipboard-not-clearing-application-cutcopymode-false.html
' Jaafar Tribak https://www.mrexcel.com/forum/excel-questions/1087948-reset-clear-clipboard-2.html
' Rory and https://excelribbon.tips.net/T008938_Determining_Your_Version_of_Excel.html
' Jack's 'COMsOLEwollupsActivelyEmmbeddedXratedObjectHookMyBouton version ' https://www.youtube.com/watch?v=jY-PEeX5xYY&t=2s
' FOR NON ENGLISH EXCEL avec moi si vou ple La légende du bouton ' ##### http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246770#p246770
Option Explicit '
Private Type POINTAPI
x As Long: Y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' VBA7 and Win64 Compiler Constant Two new compiler constants have been introduced to allow code to work across both 32 bit and 64 bit office. The Win64 constant is true if you are in a 64 bit version of office The Win32 constants is also true for 64 bit office The VBA7 constant is true for Office 2010 or later
#If VBA7 Then ' The next 5 lines turn red for Excel 2007 VBA7 Nothing ia red for GB 32 Bit Office 2010 Nothing is red for 64 Bit windows
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then ' Under is Red in KB Vista 32 Bit
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else ' ' Under is Red in KB Vista 32 Bit
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Dim hwndClip As LongPtr
Dim hwndScrollBar As LongPtr
Dim lngPtr As LongPtr
#Else
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Dim hwndClip As Long
Dim hwndScrollBar As Long
#End If
Const GW_CHILD = 5
Const S_OK = 0
' Update Version 2024 https://www.excelfox.com/forum/showthread.php/2824-Tests-Copying-pasting-Cliipboard-issues?p=24317&viewfull=1#post24317
Sub big_ClearOffPainBouton() ' aka Sub ClearOfficeClipBoard() ' OhFolloks
' Let Application.DisplayClipboardWindow = True
Dim tRect1 As RECT, tRect2 As RECT
Dim tPt As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
Dim lResult As Long
Dim i As Long
Static bHidden As Boolean
Dim MyPain As String 'COMsOLEwollupsActivelyEmmbeddedXratedObjectHookMyBoutonOhFolloks This section makes the coding work in Office 2003 also
If CLng(Val(Application.Version)) <= 11 Then ' Case 11: "Excel 2003" Windows "Excel 2004"
Let MyPain = "Task Pane"
Else
Let MyPain = "Office Clipboard"
End If
If CommandBars(MyPain).Visible = False Then
bHidden = True
CommandBars(MyPain).Visible = True ' Opens the viewer thing for the Office clipboard on XL 2007 + but sometimes opens the OfficeOnline in XL 2003?
Let Application.DisplayClipboardWindow = True ' Just incase the last line did not work
Application.OnTime Now + TimeValue("00:00:01"), "ClearOffPainBouton": Exit Sub
End If
Let hwndClip = FindWindowEx(Application.hwnd, 0, "EXCEL2", vbNullString)
Let hwndClip = FindWindowEx(hwndClip, 0, "MsoCommandBar", CommandBars(MyPain).NameLocal)
Let hwndClip = GetNextWindow(hwndClip, GW_CHILD)
Let hwndScrollBar = GetNextWindow(GetNextWindow(hwndClip, GW_CHILD), GW_CHILD)
If hwndClip And hwndScrollBar Then
GetWindowRect hwndClip, tRect1
GetWindowRect hwndScrollBar, tRect2
BringWindowToTop Application.hwnd
For i = 0 To tRect1.Right - tRect1.Left Step 50
tPt.x = tRect1.Left + i: tPt.Y = tRect1.Top - 10 + (tRect2.Top - tRect1.Top) / 2
#If VBA7 And Win64 Then
CopyMemory lngPtr, tPt, LenB(tPt)
Let lResult = AccessibleObjectFromPoint(lngPtr, oIA, vKid)
#Else
Let lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, vKid)
#End If ' ##### avec moi si vou ple La légende du bouton
If InStr("Clear All Borrar todo Effacer tout Alle löschen La légende du bouton", oIA.accName(vKid)) Then
Call oIA.accDoDefaultAction(vKid) ' This does the clearing, and
CommandBars(MyPain).Visible = Not bHidden ' this closes the viewer thing for the Office clipboard
Let bHidden = False
Exit Sub
End If
DoEvents
Next i
End If
Let CommandBars(MyPain).Visible = Not bHidden
MsgBox "Unable to clear the Office Clipboard"
End Sub
Reply With Quote
Bookmarks