Excel VBA - 将图表另存为 GIF 文件

Excel VBA - Saving Charts as GIF files

提问by Rasmus Remmer Bielidt

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

回答by Siddharth Rout

Two things

两件事情

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

1) 删除“On Error Resume Next”。否则你怎么知道路径是否正确？

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

2）与其循环形状，为什么不循环图表对象呢？例如

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

回答by user2538617

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!!!

我刚刚想出了零图思考的问题。我听说有人说excel中有一个错误，但实际上没有。excel 以某种方式拍摄快照或类似图表的内容，然后导出图像，您可以使用任何您想要的扩展名。您所要做的就是向右滚动到工作表的顶部，并确保您要导出的所有图形都可见（对您而言）。如果任何图表在下面，那么即使您引用它也不会导出，因此您需要将其一直向上拖动到顶部直到您可以看到它。只要确保您看到单元格 (A1)。有用！！！