将数据和图表从 Excel 工作表导出为 JPG

Question

我正在尝试自动化将一系列 Excel 工作表导出为 JPEG 的过程。

相关表格是钻孔记录的监测点，包含单元格中的信息以及显示趋势的图表。导出的 JPEG 将用于报告。

我从这里获取了代码： Using VBA Code how to export excel worksheets as image in Excel 2003?

稍作修改以满足我的需要。该脚本将工作表捕获在一个数组中，并逐步通过该数组动态设置打印区域以允许原始代码按预期运行。

    Sub ExportImage()

'Place all worksheets in an array

Dim ShtNames() As String
ReDim ShtNames(1 To ActiveWorkbook.Sheets.Count)
For i = 1 To Sheets.Count
ShtNames(i) = Sheets(i).Name
Next i

Dim sFilePath As String
Dim sView As String


i = 1

'step through each worksheet to export to JPG

Do Until i = Sheets.Count + 1
    Sheets(Sheets(i).Name).Activate

    Sheets(Sheets(i).Name).UsedRange.Select
    ActiveSheet.PageSetup.PrintArea = Selection.Address

'Credit to Winand and Ryan from this link https://stackoverflow.com/questions/16143877/using-vba-code-how-to-export-excel-worksheets-as-image-in-excel-2003/28541252

'Captures current window view
    sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
    ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
    Application.ScreenUpdating = True

    Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
    sFilePath = "C:\temp\Match\JPG\" & ActiveSheet.Name & ".jpg"

'Export print area as correctly scaled PNG image, courtasy of Winand
    zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
    Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
    area.CopyPicture xlPrinter
    Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
    chartobj.Chart.Paste
    chartobj.Chart.Export sFilePath, "jpg"
    chartobj.Delete

'Returns to the previous view
    ActiveWindow.View = sView

'Re-enables screen updating
    Application.ScreenUpdating = True

i = i + 1
Loop

End Sub

当我单步执行代码时，它会按预期工作，但是如果我通过单击按钮或快捷方式运行代码，则生成的图像是空白。

我在 Windows 7 机器上使用 Excel 2016。 我想也许代码运行“太快”而无法捕获 JPEG 并放入小的“睡眠”点，但这不起作用。

是否有我可能遗漏的代码的替代方法？

Answer 1

使用 Axel Richter 的建议，代码现在可以运行。 我在.Paste 和.Export 之前添加了ChartObj.Activate

问题已得到解答。 完整代码如下，以防有人需要。

Sub ExportImage()

'Place all worksheets in an array

Dim ShtNames() As String
ReDim ShtNames(1 To ActiveWorkbook.Sheets.Count)
For i = 1 To Sheets.Count
ShtNames(i) = Sheets(i).Name
Next i

Dim sFilePath As String
Dim sView As String

Dim WS As Worksheet, PntRng As Range, OffSetRw As Integer, OffSetClmn As Integer

i = 1

'step through each worksheet to export to JPG

Do Until i = Sheets.Count + 1
    Sheets(Sheets(i).Name).Activate

    Sheets(Sheets(i).Name).UsedRange.Select
    ActiveSheet.PageSetup.PrintArea = Selection.Address

'Credit to Winand and Ryan from this link https://stackoverflow.com/questions/16143877/using-vba-code-how-to-export-excel-worksheets-as-image-in-excel-2003/28541252

'Captures current window view
    sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
    ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
    Application.ScreenUpdating = False

    Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
    sFilePath = "C:\temp\Match\JPG\" & ActiveSheet.Name & ".jpg"
    Dim ChartObj As ChartObject
'Export print area as correctly scaled PNG image, courtasy of Winand
    zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
    Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
    area.CopyPicture xlPrinter
    Set ChartObj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
    ChartObj.Activate
    ChartObj.Chart.Paste
    ChartObj.Chart.Export sFilePath, "jpg"
    ChartObj.Delete

'Returns to the previous view
    ActiveWindow.View = sView

'Re-enables screen updating
    Application.ScreenUpdating = True

i = i + 1
Loop

End Sub