Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' 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 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
- #If VBA7 Then
- 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
- Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
- #Else
- 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
- Sub ClearOffPainBouton() 'OhFolloks
- '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
- If CLng(Val(Application.Version)) <= 11 Then
- Let MyPain = "Task Pane"
- Else
- Let MyPain = "Office Clipboard"
- End If
- If CommandBars(MyPain).Visible = False Then
- bHidden = True
- CommandBars(MyPain).Visible = True
- Application.OnTime Now, "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): CommandBars(MyPain).Visible = Not bHidden: 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
- Sub TestVersion() ' Rory Archibald 2015
- MsgBox Prompt:=ExcelVersion
- MsgBox Prompt:=CLng(Val(Application.Version))
- End Sub
- Private Function ExcelVersion() As String
- Dim temp As String
- 'On Error Resume Next
- #If Mac Then
- Select Case CLng(Val(Application.Version))
- Case 11: temp = "Excel 2004"
- Case 12: temp = "Excel 2008" ' this should NEVER happen!
- Case 14: temp = "Excel 2011"
- Case 15: temp = "Excel 2016 (Mac)"
- Case Else: temp = "Unknown"
- End Select
- #Else
- Select Case CLng(Val(Application.Version))
- Case 9: temp = "Excel 2000"
- Case 10: temp = "Excel 2002"
- Case 11: temp = "Excel 2003"
- Case 12: temp = "Excel 2007"
- Case 14: temp = "Excel 2010"
- Case 15: temp = "Excel 2013"
- Case 16: temp = "Excel 2016 (Windows)"
- Case Else: temp = "Unknown"
- End Select
- #End If
- #If Win64 Then
- temp = temp & " 64 bit"
- #Else
- temp = temp & " 32 bit"
- #End If
- ExcelVersion = temp
- End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement