Immer wieder mal gebraucht: Ein schneller Grafikexport aus Excel.

Die Grundlösung habe ich mal im Internet gesehen und diese gefiel mir ausgezeichnet.
Einfach ein Diagramm zu benutzen um eine Grafik zu exportieren.
Nachdem ich ein wenig damit rumgespielt hatte, schrieb ich den Code so um, dass er etwas globaler genutzt werden kann. Im Beispiel arbeitet der Code mit einem selektierten Bild.
Dies auf Bilder irgendwo in der Mappe anzupassen ist dann aber kein Problem mehr für Sie.
Es lohnt sich, den Code etwas genauer zu analysieren und weiter damit zu experimentieren.
Man kann ihn auch leicht für JPEGS anpassen.


Um das Beispiel nachzuvollziehen, erstellen Sie eine Mappe und speichern Sie diese ab.
Fügen Sie dann das abgebildete Modul ein.
Erstellen Sie eine Grafik auf einem Tabellenblatt, selektieren diese dann und starten den Code.
Im Ordner ihrer Mappe sollte dann das Gif auftauchen.

 
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
 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 & "\Test.gif" ' 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 = .Width + 7 ' hier gegebenenfalls anpassen
  iHoehe = .Height + 7 ' hier gegebenenfalls anpassen
 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
 If Not RetVal Then
  MsgBox "Bild wurde nicht exportiert", vbExclamation
 Else
  ' Wer will kann sich ja noch eine Exportmeldung ausgeben lassen
  '  MsgBox "Bild wurde exportiert", vbInformation
 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