將數據和圖表從Excel工作表導出到JPG

Question

我正在嘗試自動化將一系列Excel工作表導出為JPEG的過程。

有問題的工作表是鑽孔測井的監視點，其中包含單元格中的信息以及顯示趨勢的圖表。 導出的JPEG將在報告中使用。

我從這里獲取了代碼： 使用VBA代碼如何在Excel 2003中將Excel工作表導出為圖像？

略微修改以滿足我的需求。 該腳本將工作表捕獲到一個數組中，並逐步遍歷數組以動態設置打印區域，以允許原始代碼按預期運行。

    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