Diagramm-Export
16.08.2023 12:52:15
Rudi Maintaire
Hallo,
deine Beschreibung ist nicht gerade aufschlussreich.
als Ansatz:
Public Sub Diagramm_Export()
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
Dim wksTemp As Worksheet
Dim strGrafik As String, strPfad As String
Dim objChart As Object, objChartObject As Object
Dim oShape As Shape, sName As String
Const strFormat = "jpg"
Const cstrPfad As String = "c:\test\" 'anpassen
strGrafik = strGrafik & "." & LCase(strFormat)
strPfad = Dir(cstrPfad & Format(Date, "YYYYMMDD"), vbDirectory)
If strPfad = "" Then
strPfad = cstrPfad & Format(Date, "YYYYMMDD")
MkDir strPfad
Else
strPfad = cstrPfad & strPfad
End If
On Error GoTo Fehler
Application.ScreenUpdating = False
For Each objChartObject In ActiveSheet.ChartObjects
Set objChart = objChartObject.Chart
strGrafik = objChart.Name & "." & strFormat
objChart.CopyPicture Appearance:=xlPrinter, Size:=xlScreen, Format:=xlPicture
objChart.Deselect
Set wksTemp = Sheets.Add
wksTemp.Paste
Set oShape = wksTemp.Shapes(1)
' Der Pfad wohin das Bild gespeichert werden soll.
' Für die gewählte Variante muss die Arbeitsmappe einmal gespeichert worden sein
sTempPfad = strPfad & "\" & strGrafik
'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:=strFormat, 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 als " & strGrafik & " exportiert.", vbInformation
End If
Application.DisplayAlerts = False
wksTemp.Delete
Next objChartObject
Application.DisplayAlerts = True
Aufraeumen:
On Error Resume Next
Set oChartPic = Nothing
Set oChartArea = Nothing
Set oDia = Nothing
Set wksTemp = 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
Gruß
Rudi