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
------------
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.
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
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.
Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „hal2000“ ()