Excel VBA - Saving Charts as GIF files

问题

Programming is not my primary work function, but appearing to be the swiss army knife that I am regarded, I have been tasked with making a VBA macro in Excel that exports graphs to gif files for an automated update of info-screens in our manufacturing plants.

I have a macro that works, however, it sometimes fails and creates a gif with the correct file name but "empty" graph.

The user defines their own export path in a range in the worksheet as well as the dimensions of the exported chart.

Sub ExportAllCharts()
    Application.ScreenUpdating = False
    Const sSlash$ = "\"
    Const sPicType$ = "gif"
    Dim sChartName As String
    Dim sPath As String
    Dim sExportFile As String
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim chrt As ChartObject
    Dim StdXAxis As Double
    Dim StdYAxis As Double
    Dim ActXAxis As Double
    Dim ActYAxis As Double
    Dim SheetShowPct As Double

    Set wb = ActiveWorkbook
    Set ws = ActiveSheet

    StdXAxis = Range("StdXAxis").Value
    StdYAxis = Range("StdYAxis").Value

    sPath = Range("ExportPath").Value
    If sPath = "" Then sPath = ActiveWorkbook.Path

    For Each ws In wb.Worksheets 'check all worksheets in the workbook
        If ws.Name = "Graphs for Export" Then
            SheetShowPct = ws.Application.ActiveWindow.Zoom
            For Each chrt In ws.ChartObjects 'check all charts in the current worksheet
                ActXAxis = chrt.Width
                ActYAxis = chrt.Height
                With chrt
                    If StdXAxis > 0 Then .Width = StdXAxis
                    If StdYAxis > 0 Then .Height = StdYAxis
                End With
                sChartName = chrt.Name
                sExportFile = sPath & sSlash & sChartName & "." & sPicType
                On Error GoTo SaveError:
                    chrt.Chart.Export Filename:=sExportFile, FilterName:=sPicType
                On Error GoTo 0
                With chrt
                    .Width = ActXAxis
                    .Height = ActYAxis
                End With
            Next chrt
            ws.Application.ActiveWindow.Zoom = SheetShowPct
        End If
    Next ws
    Application.ScreenUpdating = True

MsgBox ("Export Complete")
GoTo EndSub:

SaveError:
MsgBox ("Check access rights for saving at this location: " & sPath & Chr(10) & Chr(13) & "Macro Terminating")

EndSub:

End Sub

After the help received, this was the macro code I ended up putting in the workbook: Thanks for the help.

Const sPicType$ = "gif"
Sub ExportAllCharts()

Application.ScreenUpdating = False
Dim sChartName As String, sPath As String, sExportFile As String
Dim ws As Worksheet
Dim wb As Workbook
Dim chrt As ChartObject
Dim StdXAxis As Double, StdYAxis As Double, ActXAxis As Double
Dim ActYAxis As Double, SheetShowPct As Double

Set wb = ActiveWorkbook
StdXAxis = Range("StdXAxis").Value
StdYAxis = Range("StdYAxis").Value
sPath = Range("ExportPath").Value
If sPath = "" Then sPath = ActiveWorkbook.Path

Set ws = wb.Sheets("Graphs for Export")

For Each chrt In ws.ChartObjects
    With chrt
        ActXAxis = .Width
        ActYAxis = .Height
        If StdXAxis > 0 Then .Width = StdXAxis
        If StdYAxis > 0 Then .Height = StdYAxis
        sExportFile = sPath & "\" & .Name & "." & sPicType
        .Select
        .Chart.Export Filename:=sExportFile, FilterName:=sPicType
        .Width = ActXAxis
        .Height = ActYAxis
    End With
Next chrt

Application.ScreenUpdating = True
MsgBox ("Export Complete")

End Sub

回答1:

Two things

1) Remove "On Error Resume Next". How else will you know if the path is correct or not?

2) Instead of looping through shapes, why not loop through Chart Objects instead? For example

Dim chrt As ChartObject

For Each chrt In Sheet1.ChartObjects
    Debug.Print chrt.Name
    chrt.Chart.Export Filename:=sExportFile, FilterName:=sPicType
Next

FOLLOWUP

Try this.

Const sPicType$ = "gif"

Sub ExportAllCharts()
    Application.ScreenUpdating = False

    Dim sChartName As String, sPath As String, sExportFile As String
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim chrt As ChartObject
    Dim StdXAxis As Double, StdYAxis As Double, ActXAxis As Double
    Dim ActYAxis As Double, SheetShowPct As Double

    Set wb = ActiveWorkbook

    StdXAxis = Range("StdXAxis").Value
    StdYAxis = Range("StdYAxis").Value

    sPath = Range("ExportPath").Value
    If sPath = "" Then sPath = ActiveWorkbook.Path

    Set ws = wb.Sheets("Graphs for Export")
    For Each chrt In ws.ChartObjects
        ActXAxis = chrt.Width
        ActYAxis = chrt.Height
        With chrt
            If StdXAxis > 0 Then .Width = StdXAxis
            If StdYAxis > 0 Then .Height = StdYAxis

            sChartName = .Name
            sExportFile = sPath & "\" & sChartName & "." & sPicType
            .Select
            .Chart.Export Filename:=sExportFile, FilterName:=sPicType
            .Width = ActXAxis
            .Height = ActYAxis
        End With
    Next chrt

    MsgBox ("Export Complete")

    Exit Sub
SaveError:
    MsgBox ("Check access rights for saving at this location: " & sPath & _
    Chr(10) & Chr(13) & "Macro Terminating")
End Sub

回答2:

I just figured out the problem with the zero graph thinky. I heard people say that there is a bug in excel but actually there isnt any. Somehow excel takes a snapshot or something like that of the graph and then exports the image, you can use any extension that you want. All that you have to make sure of is that you scroll right to the top of the worksheet, and make sure that all the graphs that you want to export are vissible ( to you). if any of the graphs is below, then it will not export even if you refered to it, so you need to drag it up all the way to the top until you can see it. just make sure you see cell (A1). It works!!!

来源：https://stackoverflow.com/questions/9482807/excel-vba-saving-charts-as-gif-files