ExcelVBA-将图表另存为GIF文件-ExcelVBA-SavingChartsasGIFfiles

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.

编程不是我的主要工作功能，但似乎是我所认为的瑞士军刀，我的任务是在Excel中制作VBA宏，将图形导出为gif文件，以便在我们的制造工厂中自动更新信息屏幕。

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

我有一个有效的宏，但它有时会失败，并创建一个具有正确文件名但“空”图形的gif。

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

2 个解决方案

Dim chrt As ChartObject

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

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