Диаграмма иногда экспортируется в пустой файл .jpg

Question

Этот код экспортирует Range как .jpg в местоположение, которое прикреплено к электронному письму с другим модулем, выполняющим это.

Sub Export_Dashboard_To_PC()
    Dim fileSaveName As Variant, pic As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    FName = ThisWorkbook.Path & "\Dashboard.jpg"

    With ThisWorkbook.Sheets("Dashboard")
        Sheets("Dashboard").Range(Sheets("BP").Range("AE4")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        Set sht = Sheets.Add
        sht.Shapes.AddChart
        sht.Shapes.Item(1).Select
        Set objChart = ActiveChart

        With objChart
            .ChartArea.Height = Sheets("Dashboard").Range(Sheets("BP").Range("AE4")).Height
            .ChartArea.Width = Sheets("Dashboard").Range(Sheets("BP").Range("AE4")).Width
            .ChartArea.Fill.Visible = msoFalse
            .ChartArea.Border.LineStyle = xlLineStyleNone
            .Paste
            .Export Filename:=FName, FilterName:="jpg"
        End With

        sht.Delete
    End With

    ActiveSheet.Cells(1, 1).Select
    Sheets("BP").Activate

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Все это происходит за один раз, и иногда код экспортирует изображение в виде пробела, прикрепляет его в качестве пустого к сообщению электронной почты и отправляет его. Я вижу, что проблема в экспорте, потому что, когда я иду к месту экспорта и открываю .jpg, он показывает пустую строку.

Я прошел через это много раз, каждый раз, когда это работает.

DoEvents дает мне те же результаты.

Answer 1

У меня есть такая рутина в моей коммерческой надстройке для Excel, и мне пришлось переусердствовать в ее создании. Поэтому я начал с вашего кода, немного его почистил (он не будет компилироваться с установленным Option Explicit) и вставил несколько строк, чтобы (а) попытаться заставить его работать и (б) выяснить, где он завис. Часть того, что я сделал, заключалась в том, чтобы встроить копирование / вставку в цикл, чтобы быстрее получать больше отзывов.

Sub Export_Dashboard_To_PC()
  ' turn these off for testing
  'Application.ScreenUpdating = False
  'Application.DisplayAlerts = False

  Dim RangeToCopy As Range
  ' fully qualify the ranges
  Set RangeToCopy = ThisWorkbook.Worksheets("Dashboard"). _
      Range(ThisWorkbook.Worksheets("BP").Range("AE4").Text)

  Dim wks As Worksheet
  Set wks = ThisWorkbook.Worksheets.Add
  'DoEvents ' sometimes needed after Worksheets.Add but apparently not this time

  Dim ImgNumber As Long
  For ImgNumber = 1 To 20
    Dim FName As String
    FName = ThisWorkbook.Path & "\Dashboard" & ImgNumber & ".png"
    ' PNG much better image format than JPG for worksheet images (crisper, half the size)

    Dim cht As Chart
    Set cht = wks.Shapes.AddChart(, wks.Columns(ImgNumber).Left, wks.Rows(ImgNumber).Top).Chart
      ' inserted .left and .top so I could see individual charts
    'DoEvents ' sometimes needed after Shapes.AddChart but apparently not here
    With cht
      With .ChartArea
        .Height = RangeToCopy.Height
        .Width = RangeToCopy.Width
        .Fill.Visible = msoFalse
        .Border.LineStyle = xlLineStyleNone
      End With
      DoEvents ' inserted because sometimes Range.CopyPicture throws an error
      RangeToCopy.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        ' copy as bitmap here, more reliable, rather than convert to bitmap during export
      Dim iLoop As Long, MaxLoop As Long
      MaxLoop = 10
      For iLoop = 1 To MaxLoop
        DoEvents ' inserted b/c sometimes clipboard is slow to contain copied object
        .Paste
        If .Shapes.Count > 0 Then
          ' yay, image pasted into chart
          Debug.Print iLoop
          Exit For
        End If
        If iLoop >= MaxLoop Then
          ' boo, never succeeded
          MsgBox "Export Picture Failed", vbCritical
          GoTo ExitSub
        End If
      Next
      'DoEvents
      .Export Filename:=FName, FilterName:="png"
      'DoEvents
      '.Parent.Delete ' don't delete, examine after run
    End With
  Next

ExitSub:

  'wks.Delete ' don't delete, examine after run

  ActiveSheet.Cells(1, 1).Select
  ThisWorkbook.Worksheets("BP").Activate

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Итак, я узнал, где мне нужно было поставить DoEvents, и где возникает большое узкое место. Большое узкое место - копирование диапазона в буфер обмена. VBA запускает копирование, и иногда копирование занимает больше времени, чем VBA, чтобы добраться до вставки, и VBA недостаточно терпелив, чтобы ждать. DoEvents должен заставить VBA ждать, но это не всегда работает таким образом. Если буфер обмена все еще пустой (еще не содержит копию диапазона), то ничего не вставляется, а экспортированный график остается пустым.

Итак, я поместил еще один цикл после копирования и вставил внутри цикла. После вставки, если диаграмма содержала объект, значит, вставка сработала, и я приступил к экспорту.

Обычно (в 14 из 20 больших циклов) вставка приводила к добавлению фигуры на диаграмму в первом маленьком цикле, но в 2/20 требовалось целых 6 или 7 маленьких циклов.

Итак, для окончательного кода это то, что я придумал. Я должен был вставить

Application.ScreenUpdating True

перед копией, иначе скопированный диапазон всегда был пустым (пустая фигура была вставлена ​​в диаграмму.

Sub Export_Dashboard_To_PC()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False

  Dim RangeToCopy As Range
  ' fully qualify the ranges
  Set RangeToCopy = ThisWorkbook.Worksheets("Dashboard"). _
      Range(ThisWorkbook.Worksheets("BP").Range("AE4").Text)

  Dim wks As Worksheet
  Set wks = ThisWorkbook.Worksheets.Add

  Dim FName As String
  FName = ThisWorkbook.Path & "\Dashboard_" & Format(Now, "hhmmss") & ".png"
  ' PNG much better image format than JPG for worksheet images (crisper, half the size)

  Dim cht As Chart
  Set cht = wks.Shapes.AddChart.Chart
  With cht
    With .Parent
      .Height = RangeToCopy.Height
      .Width = RangeToCopy.Width
    End With
    With .ChartArea
      .Fill.Visible = msoFalse
      .Border.LineStyle = xlLineStyleNone
    End With
    ThisWorkbook.Worksheets("Dashboard").Activate
    Application.ScreenUpdating = True ' otherwise copied region blank
    DoEvents ' inserted because sometimes Range.CopyPicture throws an error
    RangeToCopy.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Application.ScreenUpdating = False
    Dim iLoop As Long, MaxLoop As Long
    MaxLoop = 10
    For iLoop = 1 To MaxLoop
      DoEvents ' inserted b/c sometimes clipboard is slow to contain copied object
      .Paste
      If .Shapes.Count > 0 Then
        ' yay, image pasted into chart
        Exit For
      End If
      If iLoop >= MaxLoop Then
        ' never succeeded
        MsgBox "Export Picture Failed", vbCritical
        GoTo ExitSub
      End If
    Next
    .Export Filename:=FName, FilterName:="png"
  End With

ExitSub:

  wks.Delete

  ActiveSheet.Cells(1, 1).Select
  ThisWorkbook.Worksheets("BP").Activate

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Сопровождение

В моем рабочем коде (который я проверил после публикации) я никогда не установил

Application.ScreenUpdating = False

Я также не вставляю новый лист, вместо этого я помещаю свою временную диаграмму в активный лист, который содержит диапазон, который я экспортирую.

И мой внутренний цикл

With .chart
  Do Until .Pictures.Count = 1
    DoEvents
    .Paste
  Loop
  .Export sExportName
End With

То же самое, за исключением того, что предполагается, что оно никогда не попадет в бесконечный цикл.