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) Удалите «On Error Resume Next».Как еще вы узнаете, правильный ли путь или нет?

2) Вместо того, чтобы проходить по фигурам, почему бы не выполнить цикл по объектам диаграммы вместо этого?Например,

Dim chrt As ChartObject

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

FOLLOWUP

Попробуйте это.

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

Я только что понял проблему с нулевым графом Thinky. Я слышал, что люди говорят, что в Excel есть ошибка, но на самом деле ее нет. Каким-то образом Excel делает снимок или что-то вроде этого графика, а затем экспортирует изображение, вы можете использовать любое расширение, которое вы хотите. Все, что вам нужно убедиться, это прокрутить вправо до верхней части листа и убедиться, что все графики, которые вы хотите экспортировать, видны (для вас). Если какой-либо из графиков находится ниже, он не будет экспортироваться, даже если вы ссылались на него, поэтому вам нужно перетащить его вверх до самого верха, пока вы не увидите его. просто убедитесь, что вы видите ячейку (A1). Это работает !!!