时间戳

首页 > 解决方案 > 图表有时会导出到空白 .jpg 文件

excel - 图表有时会导出到空白 .jpg 文件

问题描述

此代码将 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给了我同样的结果。

标签： excelvbaexport

解决方案

我的商业 Excel 加载项中有这种例程，我不得不过度设计填充它的内容。因此，我从您的代码开始，对其进行了一些清理（它不会使用 Option Explicit 集进行编译），并插入了一些行（a）尝试使其工作，以及（b）找出它挂断的位置。我所做的部分工作是将复制/粘贴构建成一个循环，以更快地获得更多反馈。

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 等待，但它并不总是那样工作。如果剪贴板仍然为空（尚不包含范围的副本），则不会粘贴任何内容，并且导出的图表为空白。

所以我在复制之后放了另一个循环，并在循环内进行了粘贴。粘贴后，如果图表包含一个对象，那么粘贴一定有效，所以我继续导出。

通常（在 20 个大循环中的 14 个）粘贴会在第一个小循环中将形状添加到图表中，但在 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

同样的事情，除了它假设它永远不会进入无限循环。

推荐阅读