HILFEE Excel Makro Bild Export HILFEE

[bsti.ka]

Hallo, bräuchte Hilfe bei meinem Excel. Ich habe eine Tabelle in der sich mehrere Bilder befinden, die ich gerne als .jpg exportiert hätte. 
Ich habe bis jetzt das Makro:

Code:

Public Sub Grafik_Export_Gif()
 'Nach einer Idee von Rob Bruce
 ' Aufbereitet von Peter Haserodt 2002
 Dim oDia As Object, oChartArea As Object, oChartPic As Object
 Dim iBreite As Single, iHoehe As Single, RetVal As Boolean, oBlatt As Object
 Dim oBook As Object
 i = 1
 strName = i
 Dim sTempPfad As String
 On Error GoTo Fehler
 Application.ScreenUpdating = False
 Dim oShape As Shape, sName As String
 ' Nachfolgend wird die selektierte Grafik im aktiven Tabellenblatt angesprochen
 ' Dies kann man natürlich leicht ändern um spezifierte Grafiken zu exportieren
 Set oShape = ActiveSheet.Shapes(Selection.Name)
 ' Der Pfad wohin das Bild gespeichert werden soll.
 ' Für die gewählte Variante muss die Arbeitsmappe einmal gespeichert worden sein
 sTempPfad = ThisWorkbook.Path & "\" & strName & ".jpg" ' Pfad anpassen
 'Jetzt beginnt die Arbeit
 Application.Selection.CopyPicture 1, 2
 Set oBook = Application.Workbooks.Add
 Set oDia = oBook.ActiveSheet.ChartObjects.Add(0, 0, 800, 600)
 Set oChartArea = oDia.Chart
 oDia.Activate
 With oChartArea
  .ChartArea.Select
  .Paste
  Set oChartPic = .Pictures(1)
 End With
 With oChartPic
  .Left = 0
  .Top = 0
  iBreite = 1024 ' hier gegebenenfalls anpassen
  iHoehe = 1365
 End With
 With oDia
  .Border.LineStyle = xlNone
  .Width = iBreite
  .Height = iHoehe
 End With
 RetVal = oChartArea.Export(Filename:=sTempPfad, _
 Filtername:="GIF", Interactive:=False)
 ' Gewährleisten, dass wir hinter uns aufräumen

 End If
Aufraeumen:
 On Error Resume Next
 Set oChartPic = Nothing
 Set oChartArea = Nothing
 Set oDia = Nothing
 oBook.Saved = True
 oBook.Close
 Set oBook = Nothing
 Application.ScreenUpdating = True
 Exit Sub
 'Fehlerbehandlung
Fehler:
 MsgBox "Fehler beim Grafikexport, Objekt(Markierung) nicht geeignet", _
 vbExclamation
 Resume Aufraeumen
End Sub

Das Problem bei dem ist jedoch, dass es nur ein Bild exportieren kann. Kennt ihr andere schnelle Möglichkeiten oder Makros?
Die Qualität der Bilder sollte im Originalzustand bleiben. 

Vg Sebastian

[bayernsandy]

Hallo bsti.ka
Da du mit deinem Code bereits einigermaßen zufrieden warst, habe ich diesen verwendet und so umgestaltet, dass das Makro alle Grafiken kopiert.  Damit du es besser lesen kannst, habe ich alles überflüssige rausgeschmissen, so dass nur die Copy Logik übrig bleibt.
Geg.-falls musst du es noch mit den restlichen Formatierungsgeschichten aufpeppen.

Die wichtigsten Befehle sind:
 Dim oShape As Shape
 For Each oShape In ActiveSheet.Shapes
  .......
 next

Code:

Public Sub Grafik_Export_Gif()
 
 Dim oDia As Object, oChartArea As Object, oChartPic As Object
 Dim iBreite As Single, iHoehe As Single, RetVal As Boolean, oBlatt As Object
 Dim oBook As Object
 
strname = 1              '    Hier braucht es kein I = 1; Ich zähle am Ende für den Filenamen einfach Strname hoch
 Dim sTempPfad As String
 On Error GoTo Fehler
 Application.ScreenUpdating = False
dim sName As String
 

'    Diese Schleife ist neu!!!!!!  
 Dim oShape As Shape
 For Each oShape In ActiveSheet.Shapes
 
 ' Der Pfad wohin das Bild gespeichert werden soll.
 ' Für die gewählte Variante muss die Arbeitsmappe einmal gespeichert worden sein
 sTempPfad = ThisWorkbook.Path & "\" & strname & ".jpg" ' Pfad anpassen
 'Jetzt beginnt die Arbeit
 
'  In der For Schleife wird oshape bereits mit einem Shape gefüllt
'  deshalb nur kopieren
oShape.CopyPicture 1, 2
 
' Neues Workbook eröffnen und aktivieren
 Set oBook = Application.Workbooks.Add
 oBook.Activate

' Neues Chart ins Workbook einbauen, weil nur dieses exportiert werden kann
 ActiveSheet.Shapes.AddChart.Select
 ActiveChart.ChartType = xlColumnClustered
' Ins Chart die Grafik einfügen
 ActiveChart.Paste
 
'   Chart ausgeben. Es entsteht ein Fehler, wenn das QuellWorkbook noch nicht gespeichert ist, dann
'   läuft StempPfad ins leere!!!!!

 RetVal = oBook.ActiveChart.Export(Filename:=sTempPfad, _
 Filtername:="GIF", Interactive:=False)


' Jetzt Filename hochzählen
 strname = strname + 1
 
 Next

Aufraeumen:
 On Error Resume Next
 Set oChartPic = Nothing
 Set oChartArea = Nothing
 Set oDia = Nothing
 oBook.Saved = True
 oBook.Close
 Set oBook = Nothing
 Application.ScreenUpdating = True
 Exit Sub
 'Fehlerbehandlung
Fehler:
 MsgBox "Fehler beim Grafikexport, Objekt(Markierung) nicht geeignet", _
 vbExclamation
 Resume Aufraeumen
End Sub