图表有时会导出为空白的.jpg文件 [英] Chart sometimes exports to a blank .jpg file

问题描述

此代码将Range导出为.jpg到与另一个模块一起运行的电子邮件所附加的位置.

This code exports the Range as .jpg to a location that is attached to an email with another module running this.

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时，它显示为空白.

It all happens in one and sometimes the code exports the image as a blank and attach it as a blank on the email and sends it. I can see the problem is at the export because when I go to the location of the export and open the .jpg, it shows a blank.

每次工作时，我都会经过很多次.

I have stepped through it many times, every time it works.

DoEvents给我相同的结果.

推荐答案

我在我的商业Excel加载项中有这种例程，并且我不得不对其填充物进行过度设计.因此，我从您的代码开始，对其进行了一些清理(它不会使用Option Explicit设置进行编译)，并在(a)使其正常工作，以及(b)找出挂起的位置插入了几行.我所做的部分工作是将复制/粘贴构建到循环中，以更快地获取更多反馈.

I have this kind of routine in my commercial Excel add-in, and I've had to overengineer the stuffing out of it. So I started with your code, cleaned it up a bit (it wouldn't compile with Option Explicit set), and inserted some lines to (a) try to make it work, and (b) figure out where it got hung up. Part of what I did was build the copy/paste into a loop, to get more feedback faster.

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

So what I learned was where I needed to put the DoEvents, and where the big bottleneck occurs. The big bottleneck is getting the range copied into the clipboard. VBA starts the copy, and sometimes the copy takes longer than VBA takes to get to the paste, and VBA isn't patient enough to wait. DoEvents is supposed to make VBA wait, but it doesn't always work that way. If the clipboard is still empty (doesn't yet contain a copy of the range), then nothing is pasted, and the exported chart is blank.

因此，我在复制后放置了另一个循环，并在循环内进行了粘贴.粘贴之后，如果图表中包含一个对象，则该粘贴必须已起作用，因此我继续导出.

So I put another loop after the copy, and did the paste inside the loop. After the paste, if the chart contained an object, then the paste must have worked, so I proceeded to the export.

通常(在20个大循环中有14个)粘贴会导致在第一个小循环中将形状添加到图表中，但是在2/20中，它需要多达6或7个小循环.

Usually (in 14 of 20 big loops) the paste resulted in a shape being added to the chart in the first small loop, but in 2/20, it took as many as 6 or 7 small loops.

因此，对于最终代码，这是我想出的.我必须插入

So for the final code, this is what I came up with. I had to insert

Application.ScreenUpdating True

在复制之前，否则复制的范围始终为空白(将空白形状粘贴到图表中.

before the copy, otherwise the copied range was always blank (a blank shape was pasted into the chart.

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

关注

在生产代码中(我在发布此代码后检查了该代码)，我从未设置

In my production code (which I checked after posting this), I don't ever set

Application.ScreenUpdating = False

Application.ScreenUpdating = False

我也不插入新的工作表，而是将我的临时图表放在活动工作表中，其中包含要导出的范围.

I also don't insert a new sheet, instead I put my temporary chart on the active sheet, which contains the range I'm exporting.

我的内部循环是

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

一样，只是假定它永远不会陷入无限循环.

Same thing, except it assumes it will never never get into an infinite loop.

这篇关于图表有时会导出为空白的.jpg文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！