Excel VBA-сохранение диаграмм в виде файлов GIF

Программирование не является моей основной рабочей функцией, но, судя по всему, швейцарский армейский нож, который я рассматриваю, мне было поручено сделать макрос VBA в Excel, который экспортирует графики в файлы 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
2 3
excel vba excel-vba

2 ответа:

Две вещи

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

Продолжение

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

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
4

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

1