Exceldiagramme in PNGs umwandeln

[robbitop]

Ich habe für den Voodoo5 6000 Bericht für 3DC, der in den nächsten Tagen erscheinen wird, die Benchmarkdiagramme in Excel angefertigt. Nun will ich einen Haufen Diagramme möglichst einfach in's PNG Format umwandeln.

Anforderungen:
-ich muss die Zielauflösung einstellen können (mir kommt es auf 660pix breite an)
-es muss schnell und unaufwändig gehen, da es viele Diagramme sind

Bisher habe ich es mit einem Makro gemacht. Nur leider war dort keine Zielauflösung einstellbar, so dass die PNGs in der Größe leicht variieren.

Gibt's da eine brauchbare, kostenfreie Lösung?

[Juerg]

Bisher habe ich es mit einem Makro gemacht. Nur leider war dort keine Zielauflösung einstellbar, so dass die PNGs in der Größe leicht variieren.

Gibt's da eine brauchbare, kostenfreie Lösung?
Eigentlich sollte dies schon gehen wenn Du das Makro erweiterst und die Herkunftschart in eine temporäres vordefiniertes Chart hinein kopierst und dann das exportierst. Sollte wegen der kleinen Differenzen keine grossen Artefakte entstehen denk ich mal. Ungefähr so (Mit leichten Modifikationen kopiert von http://www.herber.de/forum/archiv/460to464/t461679.htm)
Sub Bild_erstellen()
Dim myChart As Chart
Dim myChartObject As ChartObject
Dim int_with As Integer,
Dim int_hight As Integer

Application.ScreenUpdating = False

Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
int_with = 660 ' <-- feste Breite
int_hight = Selection.Height ' <-- Bestehende Höhe

Set myChart = Charts.Add
Set myChartObject = ActiveChart.ChartObjects.Add(0, 0, int_with, int_hight)

With myChartObject.Chart
.Paste
.Export Filename:=ActiveWorkbook.Path & "\mybench.jpg", FilterName:="JPG", Interactive:=False
End With

Application.DisplayAlerts = False

myChart.Delete
Application.DisplayAlerts = True
Set myChart = Nothing
Set myChartObject = Nothing

Application.ScreenUpdating = True

End Sub

[robbitop]

Danke für das Makro. Da ich ein ziemlicher Heinz bin, was Programmierung angeht: Ich habe das letzte Makro von wikipedia und das habe ich einfach nur mit copy und paste nach ner Anleitung einfgefügt.


Sub DiagrammAlsPNGSpeichern()

Dim GDiagramm As Chart

Dim NameT As String

Const PfadDiagramm = "C:\temp\"

Set GDiagramm = ActiveChart

NameT = InputBox("Name der Datei:", "Export Chart", ActiveChart.Name)

If NameT <> "" Then

GDiagramm.Export Filename:=PfadDiagramm & NameT & ".PNG", FilterName:="PNG"

End If

End Sub




Beim Ausführen öffnet sich ein Fenster, das mich nach dem Namen des Diagrammes fragt und fertig ist.



Was muss ich bei deinem Makro noch genau machen, (also vorsicht, Anfänger!) damit es funktioniert?

Dim int_with As Integer, <-- hier gibts einen syntaxfehler beim Kompilieren

[Juerg]

Fehler bekommst Du weil ich da ein Komma "liegen lassen" habe. :redface:

Folgendes Skript exportiert alle Grafiken in allen Blättern einer Exceldatei in das Verzeichnis c:\temp und vergibt aufsteigende Dateinahmen. Dabei wird versucht die Breite und die Höhe auf ein festgelegtes Mass zu skalieren.

Sub DiagrammAlsPNGSpeichern()

Dim myWorksheet As Worksheet
Dim myChart As Chart
Dim myChartObject As ChartObject
Dim myTempChartO As ChartObject
Dim int_with As Integer
Dim int_hight As Integer
Dim i As Integer

Application.ScreenUpdating = False

For Each myWorksheet In ActiveWorkbook.Worksheets
For Each myChartObject In myWorksheet.ChartObjects
myChartObject.CopyPicture Appearance:=xlScreen, Format:=xlPicture

int_with = 660 ' <-- feste Breite
int_hight = 330 ' <-- feste Höhe

Set myChart = Charts.Add
Set myTempChartO = myChart.ChartObjects.Add(0, 0, int_with, int_hight)

With myTempChartO.Chart
.Paste
.Export Filename:="c:\temp\mybench" & CStr(i) & ".png", FilterName:="PNG", Interactive:=False
i = i + 1
End With

Application.DisplayAlerts = False
myChart.Delete
Application.DisplayAlerts = True

Set myChart = Nothing
Set myTempChartO = Nothing

Next myChartObject
Next myWorksheet

Set myChartObject = Nothing
Set myWorksheet = Nothing

Application.ScreenUpdating = True

End Sub

[Juerg]

Übrigens habe ich zu Hause auch noch ein paar Voodoos rumliegen. War ein Fan der ersten bis zur letzten Stunde. Hätte damals "fast" jeden Preis für eine V6000 bezahlt. Leider wurde sie abgekündigt :(. Habe damals als Ersatz eine V5500 erstanden.

[robbitop]

Wow, wo hast du das gelernt. Funktioniert auch fast.

http://img149.imageshack.us/img149/9431/mybench5ai0.th.png (http://img149.imageshack.us/my.php?image=mybench5ai0.png)

Leider erstellt er um das Bild herum so ein riesengroßes weißes Fenster. Woran liegt das?

Könnte man optional den Dateinamen aus der Diagrammüberschrift nehmen lassen?

Die V5 6000 von Raff ist leider kaputt gegangen (so ein latchup Bug)..da sind ein paar Z Dioden durchgebrannt. Glücklicherweise erst nach der Beendigung der Benches. Hank von Quantum3D repariert sie ihm aber. Der arbeitet gerade an einer Art V5 6000SE mit 256 MB.

[Juerg]

Modifiziert mit Shapes Collection da diese Skalierung unterstützen.
Private Function FixFileName(strIn As String)

Dim strOut As String

strOut = Replace(strIn, "\", "_")
strOut = Replace(strOut, "/", "_")
strOut = Replace(strOut, ":", "_")
strOut = Replace(strOut, "*", "_")
strOut = Replace(strOut, "?", "_")
strOut = Replace(strOut, Chr(34), "_")
strOut = Replace(strOut, "<", "_")
strOut = Replace(strOut, ">", "_")
FixFileName = Replace(strOut, "|", "_")

End Function

Sub DiagrammAlsPNGSpeichern()

Dim myWorksheet As Worksheet
Dim myShape As Shape
Dim myChart As Chart
Dim myChartObject As ChartObject
Dim myTempChartO As ChartObject
Dim i As Integer
Dim FileName As String

Application.ScreenUpdating = False

For Each myWorksheet In ActiveWorkbook.Worksheets
For Each myShape In myWorksheet.Shapes
With myShape
Select Case .Type
Case msoChart
i = i + 1
.ScaleWidth 660 / .Width * 2.575, msoFalse
.ScaleHeight 1330 / .Height * 2.575, msoFalse
.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set myChart = Charts.Add
Set myTempChartO = myChart.ChartObjects.Add(0, 0, myShape.Width, myShape.Height)

With myTempChartO.Chart
.Paste
FileName = FixFileName(myWorksheet.ChartObjects(i).Chart.ChartTitle.Text)
.Export FileName:=FileName & ".png", FilterName:="PNG", Interactive:=False

End With

Application.DisplayAlerts = False
myChart.Delete
Application.DisplayAlerts = True

Set myChart = Nothing

Case Else
'// do nothing
End Select
End With
Next myShape
Next myWorksheet

Set myTempChartO = Nothing
Set myShape = Nothing
Set myWorksheet = Nothing

Application.ScreenUpdating = True

End Sub

Hank hat nicht zufälligerweise einen VSA 200 Prototypen in seiner Rappelkiste den er nicht braucht und bei im nur Platz verschwendet :biggrin:

[robbitop]

.Export FileName:=FileName & ".png", FilterName:="PNG", Interactive:=False
Da sagt der debugger, dass was nicht hinhaut (auch ein "GDiagramm" vor das ".Export" hilft nicht.

[Juerg]

.Export FileName:=FileName & ".png", FilterName:="PNG", Interactive:=False
Da sagt der debugger, dass was nicht hinhaut (auch ein "GDiagramm" vor das ".Export" hilft nicht.Lass das GDiagramm vor dem .Export weg ja! :smile:

Höchst wahrscheinlich beinhaltet die Variable "FileName" einen String der nicht als Dateiname gültig ist. Das bedeutet, dass FixFileName nicht alle Sonderzeichen die als Dateiname nicht erlaubt sind rausfiltert. Füge mal folgendes vor die Zeile .Export

Debug.Print FileName & ".png"
.Export FileName:=FileName & ".png", FilterName:="PNG", Interactive:=False
Mit Strg+G sollte das Direktfenster sichtbar werden, dass den Output von Debug.Print darstellt. Darin kannst Du dann sehen was am Dateinamen nicht passt.

Falls Dir das Problem zu mühsam wird, kannst Du auch die Excel-Datei per PM mir zukommen lassen. Ich werde dann mein Möglichstes tun und Dir die Datei zurücksenden.

Ohh.. Könnte auch sein, dass ein Diagramm gar kein Titel hat. Dann Ist "FileName" ein Leerstring denn man abfangen sollte.

Ahh.. Könnte auch sein, dass zwei identische Title in den Diagrammmen auftauchen. Das führt zum Überschreiben oder Fehler. Sollte auch vermieden werden.

Uhh.. Verwende übrigens Excel 2003 und Du?

[robbitop]

Habe dir doch den Downloadlink für die Exceldatei zugeschickt (in der 2. PN). Habe sie bei keepmyfile hochgeladen. Excel 2003 nutze ich übrigens.

[Juerg]

Wie ich vermutet habe liegt das an diesem da:Höchst wahrscheinlich beinhaltet die Variable "FileName" einen String der nicht als Dateiname gültig ist. Das bedeutet, dass FixFileName nicht alle Sonderzeichen die als Dateiname nicht erlaubt sind rausfiltert Der Dateiname beinhaltet ein Neue Zeile also "Carriage Return and Linefeed".

Also: strOut = Replace(strOut, Chr(10), "_")
strOut = Replace(strOut, Chr(13), "_")

Das wars auch schon :D

[robbitop]

Äh. Den ganzen Quellcode bitte X-D
Sorry, ich bin eine totale 0 im Programmieren.

[robbitop]

Set myTempChartO = Nothing
"Fehler beim Kompilieren - Variable nicht definiert" sagt er

[Juerg]

Set myTempChartO = Nothing
"Fehler beim Kompilieren - Variable nicht definiert" sagt erÄhh... ja kannst Du einfach ersetzen mit
Set myChartObject = Nothing

[robbitop]

Jetzt funktioniert es fast perfekt. Nur dass ich wieder dieses Fensterproblem von oben habe. Und ich habe das Gefühl, dass das Bild geblurrt ist (also anscheinend nachträglich skaliert wird. Damit das nicht auftritt, müsste ein PNG mit nativer Größe erzeugt werden).

Schon jetzt danke ich dir für deine vielen Mühen Juerg.