PNG kopieren und in PP-Präsi einfügen

Hallo Zusammen,

ich habe noch nie in ein Forum geschrieben, aber ich und ChatGPT wissen nicht mehr weiter. Habe keine große Ahnung vom Programmieren bis auf die zwei Vorlesungen im Ingenieursstudium und nutze VBA immer in Kombination mit Internet-Seiten und ChatGPT.

Ich versuche einen bestimmten Tabellenabschnitt aus einer geöffneten Excel Arbeitsmappe zu kopieren (.CopyPicture) und diesen dann als png in eine geöffnete PowerPoint Datei auf einer bestimmten Folie einzufügen. Der Vorgang klappt auch regelmäßig, jedoch wird mir manchmal (ohne für mich erkennbare Regelmäßigkeit) eine Fehlermeldung entweder in Bezug auf das Einfügen des Bildes aus dem Zwischenspeicher oder (seltener) hinsichtlich des kopiervorgangs angezeigt. Wenn man dann, nach dem Klick auf "Debuggen" einfach wieder auf das "Play"-Symbol im VBA Editor klickt, läuft das Programm meist ohne Probleme weiter.

Der problematische Code:

ActiveWorkbook.Sheets("Name des Sheets").Range("Zellebereich der kopiert werden soll").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
pptSlideNum.Shapes.PasteSpecial DataType:=ppPastePNG

(pptSlideNum ist ist die vorher definierte Powerpoint Folie)

Habe es schon auf viele unterschiedliche Wege versucht, aber der Code hat bisher am besten funktioniert

Die Fehelrmeldung lautet: Laufzeitfehler '-2147188160 (80048240)':
Slide.Paste : Invalid request. Clipboard is empty or contains data which may not be pasted here.

Der Code ist eine Logik eingebettet, die variabel je nach dem wie viele Zeilen die zu kopierende Tabelle hat, neue PowerPoint Folien erzeugt und immer 19 Zeilen der Tabelle nacheinander kopiert und auf die neu erzeugten PowerPoint Folien einfügt. Der "problematische" Code kommt demnach in verschiedenen If abfragen und Schleifen öfter vor.

Ich habe leider keine Ahnung mehr wie ich das Problem lösen kann.

Ich hoffe hier kann mir jemand weiterhelfen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPtr Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr Public Function ClearClipboard() OpenClipboard (0&) EmptyClipboard CloseClipboard End Function Sub deineRoutine() '.... ActiveWorkbook.Sheets("Name des Sheets").Range("Zellebereich der kopiert werden soll").CopyPicture Appearance:=xlScreen, Format:=xlBitmap pptSlideNum.Shapes.PasteSpecial DataType:=ppPastePNG Call ClearClipboard '.... 'evtl Abfragen, ob leer mit Paste in Excel bspw End Sub

Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Public Function ClearClipboard() As Boolean On Local Error Resume Next Dim lngRet As Long lngRet = 0 lngRet = OpenClipboard(lngRet) If lngRet = 1 Then lngRet = lngRet Or EmptyClipboard() lngRet = lngRet Or CloseClipboard() End If ClearClipboard = lngRet = 1 End Function

ActiveWorkbook.Sheets("Name des Sheets").Range("Zellebereich der kopiert werden soll").CopyPicture Appearance:=xlScreen, Format:=xlPicture pptSlideNum.Shapes.PasteSpecial Call ClearClipboard DoEvents:DoEvents

Call ClearClipboard DoEvents:DoEvents ActiveWorkbook.Sheets("Name des Sheets").Range("Zellebereich der kopiert werden soll").CopyPicture Appearance:=xlScreen, Format:=xlPicture pptSlideNum.Shapes.PasteSpecial

excelWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture Appearance:=xlScreen, Format:=xlPicture On Error Resume Next Do excelWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture Appearance:=xlScreen, Format:=xlPicture If Err.Number = 0 Then Exit Do Err.Clear Loop On Error Resume Next Do pptSlideNum.Shapes.PasteSpecial If Err.Number = 0 Then Exit Do Err.Clear Loop ' Call ClearClipboard For i = 0 To 10000 DoEvents Next

Code:

On Error Resume Next
  Do
     ActiveWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture _
                    Appearance:=xlScreen, Format:=xlBitmap
     WSh2.Range(sBer).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
     If Err.Number = 0 Then Exit Do
     Err.Clear
  Loop
  pptSlideNum.Shapes.PasteSpecial DataType:=ppPastePNG

excelWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture Appearance:=xlScreen, Format:=xlPicture On Error Resume Next Do excelWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture Appearance:=xlScreen, Format:=xlPicture If Err.Number = 0 Then Exit Do Err.Clear Loop pptSlideNum.Shapes.PasteSpecial On Error Resume Next If Err.Number > 0 Then Do pptSlideNum.Shapes.PasteSpecial If Err.Number = 0 Then Exit Do Err.Clear Loop End If

Hallo Bibo,

sorry, ich hatte beim Kopieren meines Musters vergessen, einen Teil meines eigenen Codes herauszunehmen.
Aber Du hast es ja dann erkannt, dass es doppelt war.

Es geht hier eigentlich nur darum, einen evtl. auftretenden Fehler beim Kopieren abzufangen. Dazu wird der Kopierbefehl einfach in die Fehlerschleife eingebettet.
Der Kopierbefehl gehört dann natürlich nur einmalig in die Do-Schleife, den vor der Schleife kannst Du weglassen.

Beim Einfügen hast Du diese Fehlerschleife noch mal eingebaut. Ich denke, hier ist es nicht sinnvoll.
Warum kein Bild eingefügt wird, kann ich nicht sagen.

Probiere doch mal mit folgendem Code, was die Funktion bei den einzelnen Kopiervorgängen ausspuckt und ob bei leerer Zwischenablage eine evtl. Wiederholung helfen würde.
Wenn die Zwiscehnablage nicht leer ist, aber trotzdem kein Bild kommt, ist es u.U. ein anderes Problem. Ansonsten ist es schwierig per Ferndiagnose das herauszufinden.

BTW: "Application.CutCopyMode = False" leert ja auch die Zwischenablage, ist aber m.E. an Excel gebunden, so als würde ich "OpenCliboard Application.hwnd" machen.
Ob's 'nen Unterschied macht oder die Leerung überhaupt notwendig ist, kann ich nicht beurteilen. Ich kopiere meist ohne vorherige Leerung.

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Long) As Long

Sub test()
'  OpenClipboard 0& ' ggf. Application.hwnd
'  EmptyClipboard
'  CloseClipboard
  
  On Error Resume Next
  Do
     excelWorkbook.Sheets("Sheet").Range("Kopierbereich").CopyPicture Appearance:=xlScreen, Format:=xlPicture
     If Err.Number = 0 Then Exit Do
     Err.Clear
  Loop
  If IsClipboardFormatAvailable(3) > 0 Then 'Text=1, xlBitMap=2, xlPicture=3
     pptSlideNum.Shapes.PasteSpecial
  Else
     MsgBox "nix Picture in Clipboard"
  End If
End Sub

Gruß KH

Beliebteste Forumthreads (12 Monate)

PNG kopieren und in PP-Präsi einfügen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

PNG kopieren und in PP-Präsi einfügen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread