Office-Zwischenablage mit VBA Löschen 2

1978lazigo · 21. September 2013, 15:04

Hallo liebe Community,

Bei meinem ersten Beitrag "Office-Zwischenablage mit VBA löschen" hatte ich einen Weg beschrieben wie man Office Clipboard über VBA und API leeren kann
Nun habe ich einen anderen Weg gefunden (Internet) und das will ich euch nicht vorenthalten.
Ganz ohne API-Funktionen geht es leider nicht. Diesmal werden wir uns der Schnittstelle Microsoft Active Accessibility (% windir%\system32\oleacc.dll) bedienen um die Position aller sichtbaren Controls (Buttons) zu ermitteln.
Der Code, den ich zur Verfügung stelle, läuft unter Excel 2010 (deutsche Version) 32bit.
Meine Bemühungen den Code unter 64Bit-Excel zum Laufen zu bringen scheiterten jedoch. Beim Aufruf der Funktionen "Function GetWndText(ByVal hWnd As Long) As String" und/oder "Function FindChildWindow(ByVal hParent As Long, Optional cls As String = "", Optional title As String = "") As Long“ ist Excel jedes Mal abgestürzt.
Ich würde mich freuen, wenn jemand den Code auf 64Bit-Excel portieren kann.
Wer probieren will, kann den Quelcode kopieren und in einem allgemeinen Modul einfügen. Mit "Sub ClearOfficeClipboard ()" können Sie Office-Zwischenablage leeren. Mit "Sub Clear_Word_ClipBoard_From_Excel ()" kann die Office- Zwischenablage von Excel aus über "Word" gelöscht werden.

Viel Spaß

'Code

Spoiler anzeigen

Visual Basic-Quellcode

Option Explicit
Option Compare Text
''verwendung
'Sie brauchen einen Verweis auf "Accessibility" (% windir%\system32\oleacc.dll)
'Der Code funktioniert nur bei der deutschen Version von Office. _
Für andere Sprachen müssen Sie den korrekten Wert für drei _
'Zeichenfolgen finden, die lokalisiert sind:
'1) "Zusammenstellen und Einfügen 2.0" "Collect and Paste 2.0"
'2) "Alle löschen" "Clear All"
'3) "Office ClipBoard" "Office ClipBoard"
Const CHILDID_SELF = 0&
Const ROLE_TITLEBAR = &H1&
Const ROLE_MENUBAR = &H2&
Const ROLE_SCROLLBAR = &H3&
Const ROLE_GRIP = &H4&
Const ROLE_SOUND = &H5&
Const ROLE_CURSOR = &H6&
Const ROLE_CARET = &H7&
Const ROLE_ALERT = &H8&
Const ROLE_WINDOW = &H9&
Const ROLE_CLIENT = &HA&
Const ROLE_MENUPOPUP = &HB&
Const ROLE_MENUITEM = &HC&
Const ROLE_TOOLTIP = &HD&
Const ROLE_APPLICATION = &HE&
Const ROLE_DOCUMENT = &HF&
Const ROLE_PANE = &H10&
Const ROLE_CHART = &H11&
Const ROLE_DIALOG = &H12&
Const ROLE_BORDER = &H13&
Const ROLE_GROUPING = &H14&
Const ROLE_SEPARATOR = &H15&
Const ROLE_TOOLBAR = &H16&
Const ROLE_STATUSBAR = &H17&
Const ROLE_TABLE = &H18&
Const ROLE_COLUMNHEADER = &H19&
Const ROLE_ROWHEADER = &H1A&
Const ROLE_COLUMN = &H1B&
Const ROLE_ROW = &H1C&
Const ROLE_CELL = &H1D&
Const ROLE_LINK = &H1E&
Const ROLE_HELPBALLOON = &H1F&
Const ROLE_CHARACTER = &H20&
Const ROLE_LIST = &H21&
Const ROLE_LISTITEM = &H22&
Const ROLE_OUTLINE = &H23&
Const ROLE_OUTLINEITEM = &H24&
Const ROLE_PAGETAB = &H25&
Const ROLE_PROPERTYPAGE = &H26&
Const ROLE_INDICATOR = &H27&
Const ROLE_GRAPHIC = &H28&
Const ROLE_STATICTEXT = &H29&
Const ROLE_TEXT = &H2A&
Const ROLE_PUSHBUTTON = &H2B&
Const ROLE_CHECKBUTTON = &H2C&
Const ROLE_RADIOBUTTON = &H2D&
Const ROLE_COMBOBOX = &H2E&
Const ROLE_DROPLIST = &H2F&
Const ROLE_PROGRESSBAR = &H30&
Const ROLE_DIAL = &H31&
Const ROLE_HOTKEYFIELD = &H32&
Const ROLE_SLIDER = &H33&
Const ROLE_SPINBUTTON = &H34&
Const ROLE_DIAGRAM = &H35&
Const ROLE_ANIMATION = &H36&
Const ROLE_EQUATION = &H37&
Const ROLE_BUTTONDROPDOWN = &H38&
Const ROLE_BUTTONMENU = &H39&
Const ROLE_BUTTONDROPDOWNGRID = &H3A&
Const ROLE_WHITESPACE = &H3B&
Const ROLE_PAGETABLIST = &H3C&
Const ROLE_CLOCK = &H3D&
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
'Global objButton As AccObject
Dim accButton As AccObject
Const WM_GETTEXT = &HD
Public lngChild As Long, strClass As String, strCaption As String
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
Private Declare PtrSafe Sub Sleep Lib _
"kernel32.dll" (ByVal dwMilliseconds As Long)
'' Fensterklassenname
Function GetWndClass(ByVal hWnd As Long) As String
Dim buf As String, retval As Long
buf = Space(256)
retval = GetClassName(hWnd, buf, 255)
GetWndClass = Left(buf, retval)
End Function
'Fenstertitel
Function GetWndText(ByVal hWnd As Long) As String
Dim buf As String, retval As Long
buf = Space(256)
retval = SendMessage(hWnd, WM_GETTEXT, 255, buf)
GetWndText = Left(buf, InStr(1, buf, Chr(0)) - 1)
End Function
'Die Rückruffunktion von 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
'Das Fensterhandle eines untergeordneten Fensters auf der Grundlage seiner Klasse und Titel finden
Function FindChildWindow(ByVal hParent As Long, Optional cls As String = "", Optional title As String = "") As Long
lngChild = 0
strClass = cls
strCaption = title
Call EnumChildWindows(hParent, AddressOf EnumChildWndProc, 0)
FindChildWindow = lngChild
End Function
'Ruft die IAccessible-Schnittstelle aus einem Fensterhandle
Function IAccessibleFromHwnd(hWnd As Long) As IAccessible
Dim oIA As IAccessible
Dim tg As tGUID
Dim lReturn As Long
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
'Ruft das IAccessible Objekt für die Form
lReturn = AccessibleObjectFromWindow(hWnd, 0, tg, oIA)
Set IAccessibleFromHwnd = oIA
End Function
'Rekursiv auf der Suche nach einem AccessibleChild mit angegebenen AccName und AccRole
'in der accessibility-Struktur (accessibility tree)
Function FindAccessibleChild(oParent As IAccessible, strName As String, lngRole As Long) As AccObject
Dim lHowMany As Long
Dim avKids() As Variant
Dim AHowMany 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
AHowMany = 0
If AccessibleChildren(oParent, 0, lHowMany, avKids(0), AHowMany) <> 0 Then
MsgBox "Error retrieving accessible children!"
'MsgBox "Fehler beim Abrufen"
Set FindAccessibleChild.objIA = Nothing
Exit Function
End If
On Error Resume Next
For i = 0 To AHowMany - 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
'Generic Routine, die Fenster-Handle des aktiven Fensters einer Office-Anwendung
Function GetOfficeAppHwnd(app As Object) As Long
GetOfficeAppHwnd = FindWindow(vbNullString, GetOfficeAppWindowTitle(app))
End Function
''Ruft das Fenster-Handle von Office ClipBoard
'Sie können die Fenster-Klasse und den Titel mit Spy, Inspect32 oder anderen Werkzeugen herausfinden
Function GetOfficeTaskPaneHwnd(app As Object) As Long
GetOfficeTaskPaneHwnd = FindChildWindow(GetOfficeAppHwnd(app), _
"MsoCommandBar", "Office ClipBoard") '"Office ClipBoard"
End Function
'Das Fenster Titel des Zwischenablage-Fensters scheint sprachabhängig zu sein,
Function GetOfficeClipboardHwnd(app As Object) As Long
GetOfficeClipboardHwnd = FindChildWindow(GetOfficeAppHwnd(app), , "Zusammenstellen und Einfügen 2.0") '"Collect and Paste 2.0"
End Function
'Generic Routine
'
Function GetOfficeAppWindowTitle(app As Object) As String
On Error GoTo ErrorHandler
Select Case app.Name
Case "Microsoft Word"
GetOfficeAppWindowTitle = app.ActiveWindow.Caption & " - " & app.Name
Case Else
GetOfficeAppWindowTitle = app.Name & " - " & app.ActiveWindow.Caption
End Select
Exit Function
ErrorHandler:
MsgBox "Unsupported Office application!" 'Nicht unterstützte Office-Anwendung!
GetOfficeAppWindowTitle = ""
End Function
'Mit Active Accessibility Office-Zwischenablage löschen
'Voraussetzung Annahme:
'Dies läuft in Word oder Excel als Makro und die globalen Application-Objekte verfügbar
Sub ClearOfficeClipboard()
'Static accButton As AccObject
If accButton.objIA Is Nothing Then
Dim fShown As Boolean
fShown = CommandBars("Office ClipBoard").Visible
' Range("A1").Copy
Sleep (1200)
If Not (fShown) Then
CommandBars("Office ClipBoard").Enabled = True
CommandBars("Office ClipBoard").Visible = True
End If
accButton = FindAccessibleChildInWindow(GetOfficeClipboardHwnd(Application), "Alle löschen", ROLE_PUSHBUTTON) 'Clear All
End If
If accButton.objIA Is Nothing Then
MsgBox "Unable to locate the ""Clear All"" button!"
Else
accButton.objIA.accDoDefaultAction accButton.lngChild
'MsgBox "Alles erledigt. Die Office Zwischenablage entleert"
Set accButton.objIA = Nothing
End If
'Ausgangzustand wiederherstellen
CommandBars("Office ClipBoard").Visible = fShown
Application.CutCopyMode = False
End Sub
''' Mit Active Accessibility, die Office-Zwischenablage löschen
'' Eingabe: app - als Application-Objekt von einer Office-Anwendung
'' Annahme: Aufgabenbereich Zwischenablage wird in der Office-Anwendung gezeigt (app-Objekt)
Function ClearOfficeClipboard_(app As Object) As Boolean
Dim oButton As AccObject, fShow As Boolean
oButton = FindAccessibleChildInWindow(GetOfficeClipboardHwnd(app), "Alle löschen", ROLE_PUSHBUTTON) 'Alle löschen 'Clear All
If oButton.objIA Is Nothing Then
MsgBox "Unable to locate the ""Clear All"" button!" '"Kann die Taste 'Alle Löschen' nicht lokalisieren"
ClearOfficeClipboard_ = False
Else
oButton.objIA.accDoDefaultAction oButton.lngChild
ClearOfficeClipboard_ = True
End If
End Function
Sub Clear_Word_ClipBoard_From_Excel()
Dim wdAnw As Object
Dim wdDok As Object
Dim Fehler
'Dim Wapp As Word.Application
On Error Resume Next
Set wdDok = GetObject(, "Word.Application") 'Word Instanz suchen
Fehler = Err.Number
On Error GoTo 0
If Fehler = 429 Then
Set wdAnw = CreateObject("Word.Application") 'Word Instanz generieren
wdAnw.Visible = True 'word zeigen
If wdAnw.Documents.Count <= 0 Then 'wenn kein dokument
wdAnw.Documents.Add 'dokument zufügen
End If
Sleep (1000)
Else
Set wdAnw = GetObject(, "Word.Application") 'Word Instanz verbinden
If wdAnw.Documents.Count <= 0 Then 'wenn kein dokument
wdAnw.Documents.Add 'dokument zufügen
End If
Sleep (1000)
End If
If ClearOfficeClipboard_(wdAnw) Then
MsgBox "Office-Zwischenablage ist geleert"
End If
'ObjektVerweise nothing
If Not wdAnw Is Nothing Then
wdAnw.ActiveDocument.Saved = True
wdAnw.ActiveDocument.Close
wdAnw.Quit
End If
If Not wdAnw Is Nothing Then
Set wdDok = Nothing
Set wdAnw = Nothing
End If
End Sub

------------
Dieser Code ist eine Erweiterung und basiert auf diesem Blog-Post: blogs.msdn.com/b/guowu/archive/2004/12/22/330231.aspx
------------

Edit by hal2000:
- Expander + Code-Tags eingefügt.
- Quelle hinzugefügt.

Office-Zwischenablage mit VBA Löschen 2

Office-Zwischenablage mit VBA Löschen 2

Visual Basic-Quellcode

Tags

Ähnliche Themen

1 Benutzer hat hier geschrieben