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

Question

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

我有一个宏的工作，但是，它有时会失败，并创建一个与正确的文件名，但“空”图形的GIF。

用户在工作表的范围内定义自己的导出路径以及导出图表的尺寸。

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 

得到的帮助后，这是宏代码我最后决定将在工作簿： 感谢您的帮助。

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 

Answer 1

两件事情

1）删除 “上的错误继续下一步”。如果路径是否正确，你还会怎么知道？

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 

Answer 2

我只是想出了零图思想的问题。我听说有人说Excel中有一个错误，但实际上并没有。不知何故，excel需要一个快照或类似于图形的东西，然后导出图像，你可以使用任何你想要的扩展名。所有你必须确定的是你直接滚动到工作表的顶部，并确保你想要导出的所有图形都是可分离的（对你而言）。如果有任何图表在下面，那么即使您参考它也不会导出，因此您需要将它一直拖到顶部直到您看到它。只要确保你看到细胞（A1）。有用！！！