Kopieren von Bildern mittels VBA

Question

Hallo Leute,
ich habe mal wieder ein Problem mit dem Kopieren von Bildern per VBA.
Mir liegt ein Tabellenblatt mit Text und mehreren Grafiken (Briefkopf, Digitale Unterschriften etc) vor. Der Text wird per VBA dem Auftrag angepasst und in ein neues Tabellenblatt kopiert. Bei dem versuch die Grafiken zu kopieren bekomme ich jedes mal den gleichen Fehler.
Erst mal der Code (Den ich glaube ich sogar aus diesem Forum geklaut habe)

Sub Copy_Bilder()

Dim Pname As String
Dim Pleft As Double
Dim Ptop As Double

Sheets(2).DrawingObjects.Delete

For i = 1 To Sheets(1).Shapes.Count

Sheets(1).Shapes("Picture " & CStr(i)).Copy
Ptop = Sheets(1).Shapes("Picture " & CStr(i)).Top
Pleft = Sheets(1).Shapes("Picture " & CStr(i)).Left


With Sheets(2)
.Paste
.Shapes("Picture " & CStr(i)).Left = Pleft
.Shapes("Picture " & CStr(i)).Top = Ptop
End With

Next i

End Sub

In der Zeile " .Shapes("Picture " & CStr(i)).Left = Pleft" bekomme ich jedes mal im ersten Schleifendurchlauf den Fehler "Laufzeitfehler 5 Ungültiger Prozeduraufruf oder ungültiges Argument".
Bei dem Versuch die "Shapes" im Programmcode durch "Drawing Objects" zu ersetzen kommt in der gleichen Zeile "Laufzeitfehler 1004 Anwendungs- oder Objektdefinierter Fehler.

Könnt ihr mir weiterhelfen?
lieben Dank
Gruß SirSolaris

Answer 1

Hallo Sir Solaris,

also bei mir funktioniert dein Code. Den Fehler kann ich leider nicht nachvollziehen. Es könnte evtl. daran liegen, dass vielleicht nicht jedes Shape den Namen Picture gefolgt von einem Leerzeichen und einer laufenden Nr. trägt. Evtl. ist die lfd. Nr. nicht durchgängig?Beachte hier, dass auch Linien oder Zellkommentare Shapes darstellen. In diesem Fall kommt bei mir aber der Laufzeitfehler: -2147024809 (80070057) "Das Element mit dem angegebenen Namen wurde nicht gefunden."

Bei den DrawingObjects hast du möglicherweise nicht auf Alle Eigenschaften Zugriff. Dann musst du die Eigenschaft .Shaperange verwenden um auf die zugehörigen Shapeeigenschaften zugreifen zu können. Damit wären wir aber dann wieder bei Problem 1.

Probier mal ob dieser Code vielleich besser läuft.

Sub Copy_Bilder()

Dim Pname As String
Dim Pleft As Double
Dim Ptop As Double

Sheets(2).DrawingObjects.Delete

For i = 1 To Sheets(1).Pictures.Count

Sheets(1).Pictures(i).Copy
Ptop = Sheets(1).Pictures(i).Top
Pleft = Sheets(1).Pictures(i).Left


With Sheets(2)
.Paste
.Pictures(i).Left = Pleft
.Pictures(i).Top = Ptop
End With

Next i

End Sub

Gruß Mr. K.

Answer 2

wie gesagt, evtl. auch .Pictures(i).ShapeRange.Left = Pleft probieren.