如何使用VBA代码在Excel 2003中将Excel工作表导出为图像？

Question

请建议更好的方法，将Excel工作表中的数据范围导出为图像，可以选择 .jpeg、.png 或 .gif 格式。

- Vishal I P

---

你使用的Excel版本是哪个？是Excel 2007还是Excel 2010？因为在最近的版本中，有一个名为“复制...作为图片”的功能，可能可以通过VBA自动化实现。 - Our Man in Bananas

我使用的是 Excel 2003。 - Vishal I P

Answer 1

您是否想尝试我在互联网某个地方找到并使用过的以下代码？

它使用图表对象的导出函数以及范围对象的CopyPicture方法。

参考文献：

• MSDN - Export method as it applies to the Chart object. to save the clipboard as an Image

• MSDN - CopyPicture method as it applies to the Range object to copy the range as a picture

  dim sSheetName as string
  dim oRangeToCopy as range
  Dim oCht As Chart
  
  sSheetName ="Sheet1" ' worksheet to work on
  set  oRangeToCopy =Range("B2:H8") ' range to be copied
  
  Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
  set oCht =charts.add
  
  with oCht
      .paste
      .Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
  end with
  

- Our Man in Bananas

---

在这一行中，我无法正常工作：Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap。 - juanora

有没有办法提高导出图像的大小？默认大小无法提供图表的详细信息。 - Vivek

@Vivek：我只能建议你看一下其他的答案 - 它们可能会对此提供一些帮助... - Our Man in Bananas

Answer 2

我尝试通过几种方式改进这个解决方案。现在生成的图像具有正确的比例。

Set sheet = ActiveSheet
output = "D:\SavedRange4.png"

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 output, "png"
chartobj.Delete

- Winand

---

出于某种原因，我收到了一张空白图片。 - ZygD

@ZygD 也许当前工作表上的“PrintArea”为空？ - Winand

我遇到了同样的问题。当我逐行调试代码时，图像可以正常工作，但如果我直接运行它，则图像会被创建但是显示为空白。我还尝试了加入时间延迟，但也没有帮助。@Winand - Joe K

@JoeK，如果您删除了最后两行代码（.export 和 .delete），那么这张图片会是空白的吗？ - Winand

Answer 3

感谢大家！我稍微修改了Winand的代码，使它可以将文件导出到用户的桌面，无论是哪个工作表在使用。我在代码中给出了这个想法的来源（感谢Kyle）。

Sub ExportImage()


Dim sFilePath As String
Dim sView As String

'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:
'https://dev59.com/lWMm5IYBdhLWcg3whfSe
sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'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, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:" & Chr(10) & Chr(10) & sFilePath)

End Sub

- Ryan Bradley

Answer 4

如果您将选择和保存工作簿路径添加到Ryan Bradley的代码中，那么它将更具弹性。

 Sub ExportImage()

Dim sheet, zoom_coef, area, chartobj
Dim sFilePath As String
Dim sView As String

'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:
'https://dev59.com/lWMm5IYBdhLWcg3whfSe
'sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'##################
'Łukasz : Save to  workbook directory
'Asking for filename insted of ActiveSheet.Name is also good idea, without file extension
dim FileID as string
FileID=inputbox("Type a file name","Filename...?",ActiveSheet.Name)
sFilePath = ThisWorkbook.Path & "\" & FileID & ".png"

'Łukasz:Change code to use Selection
'Simply select what you want to export and run the macro
'ActiveCell should be: Top Left 
'it means select from top left corner to right bottom corner

Dim r As Long, c As Integer, ar As Long, ac As Integer

    r = Selection.rows.Count
    c = Selection.Columns.Count
    ar = ActiveCell.Row
    ac = ActiveCell.Column
    ActiveSheet.PageSetup.PrintArea = Range(Cells(ar, ac), Cells(ar, ac)).Resize(r, c).Address

'Export print area as correctly scaled PNG image, courtasy of Winand
'Łukasz: zoom_coef can be constant = 0 to 5 can work too, but save is 0 to 4
zoom_coef = 5 '100 / sheet.Parent.Windows(1).Zoom
'#############
Set area = sheet.Range(sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter  'xlBitmap '
Set chartobj = sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here: :" & Chr(10) & Chr(10) & sFilePath)
'Close
End Sub

- Łukasz Małarzewski

Answer 5

Winand，质量对我也是一个问题，所以我做了这个：

For Each ws In ActiveWorkbook.Worksheets
    If ws.PageSetup.PrintArea <> "" Then
        'Reverse the effects of page zoom on the exported image
        zoom_coef = 100 / ws.Parent.Windows(1).Zoom
        areas = Split(ws.PageSetup.PrintArea, ",")
        areaNo = 0
        For Each a In areas
            Set area = ws.Range(a)
            ' Change xlPrinter to xlScreen to see zooming white space
            area.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
            Set chartobj = ws.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
            chartobj.Chart.Paste
            'scale the image before export
            ws.Shapes(chartobj.Index).ScaleHeight 3, msoFalse, msoScaleFromTopLeft
            ws.Shapes(chartobj.Index).ScaleWidth 3, msoFalse, msoScaleFromTopLeft
            chartobj.Chart.Export ws.Name & "-" & areaNo & ".png", "png"
            chartobj.delete
            areaNo = areaNo + 1
        Next
    End If
Next

请看这里：https://robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/

- MartinC

---

我看到你在这里做了什么。通过修改“zoom_coef = ... * 3”这一行，您可以实现相同的结果。 - Winand

不行，如果我这么做，图像会变小并带有额外的白色空间。 - MartinC

嗯，我在发布之前已经使用Excel2013进行了检查。你能否将代码粘贴到Pastebin上，以确保生成带有空格的图像？（有时候我希望SO成为一个论坛。） - Winand

首先，我使用的是2010版本，而问题涉及到2003版本。 xlScreen：将缩放，xlPrinter：将调整大小。 我的代码中省略了xlPrinter，因此默认为xlScreen。 但是你的代码旨在抵消屏幕左下角缩放调整的影响。 - MartinC

但如果缩放比例为100％，它会按照您所说的方式执行。我们需要结合缩放和比例，以便在导出时无论工作表的缩放如何都能保证质量。 - MartinC

我们为什么需要xlScreen呢？它会保留筛选按钮、默认网格等。使用xlPrinter，我们可以根据窗口缩放级别进行调整，并可以添加额外的系数（>1）来提高质量。此外，结果看起来与打印或导出为PDF的结果相同，没有空白。 - Winand

Answer 6

没有图表的解决方案

Function SelectionToPicture(nome)

'save location ( change if you want )
FName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & nome & ".jpg"

'copy selection and get size
Selection.CopyPicture xlScreen, xlBitmap
w = Selection.Width
h = Selection.Height



With ThisWorkbook.ActiveSheet

    .Activate

    Dim chtObj As ChartObject
    Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
    chtObj.Name = "TemporaryPictureChart"

    'resize obj to picture size
    chtObj.Width = w
    chtObj.Height = h

    ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
    ActiveChart.Paste

    ActiveChart.Export FileName:=FName, FilterName:="jpg"

    chtObj.Delete

End With
End Function

- Leonardo Mezavilla

Answer 7

这给我最可靠的结果：

Sub RangeToPicture()
  Dim FileName As String: FileName = "C:\file.bmp"
  Dim rPrt As Range: Set rPrt = ThisWorkbook.Sheets("Sheet1").Range("A1:C6")
  'Add a Zoom to increase the resolution of the image.          
  ActiveWindow.Zoom = 300
  
  Dim chtObj As ChartObject
  rPrt.CopyPicture xlScreen, xlBitmap
  Set chtObj = ActiveSheet.ChartObjects.Add(1, 1, rPrt.Width, rPrt.Height)
  chtObj.Activate
  ActiveChart.Paste
  ActiveChart.Export FileName
  chtObj.Delete
  'Reset Zoom to innitial zoom of the image.          
  ActiveWindow.Zoom = 100
End Sub

- ZygD

---

这个在2020年对我有用，其他很多都没用。 - Sam Fed

Answer 8

根据Philip提供的链接，我让它正常工作了。

Worksheets("Final Analysis Sheet").Range("A4:G112").CopyPicture xlScreen, xlBitmap

    Application.DisplayAlerts = False
    Set oCht = Charts.Add
    With oCht
        .Paste
        .Export Filename:="C:\FTPDailycheck\TodaysImages\SavedRange.jpg", Filtername:="JPG"
        .Delete
    End With

- ambassallo

Answer 9

有一种更直接的方法可以将范围图像导出到文件中，无需创建临时图表。它利用PowerShell将剪贴板保存为.png文件。

使用vba CopyPicture命令将范围复制到剪贴板作为图像是很简单的，如其他答案中所示。

一个保存剪贴板的PowerShell脚本只需要两行代码，如Save Image from clipboard using PowerShell中所述。

VBA可以启动一个PowerShell脚本并等待其完成，如Wait for shell command to complete中所述。

将这些想法结合起来，我们得到以下例程。我只在Windows 10下使用Office 2010版本的Excel进行了测试。请注意，有一个内部常量AidDebugging，可以设置为True以提供有关例程执行的附加反馈。

Option Explicit

' This routine copies the bitmap image of a range of cells to a .png file.
' Input arguments:
'    RangeRef -- the range to be copied. This must be passed as a range object, not as the name
'                or address of the range.
'    Destination -- the name (including path if necessary) of the file to be created, ending in
'                the extension ".png". It will be overwritten without warning if it exists.
'    TempFile -- the name (including path if necessary) of a temporary script file which will be
'                created and destroyed. If this is not supplied, file "RangeToPNG.ps1" will be
'                created in the default folder. If AidDebugging is set to True, then this file
'                will not be deleted, so it can be inspected for debugging.
' If the PowerShell script file cannot be launched, then this routine will display an error message.
' However, if the script can be launched but cannot create the resulting file, this script cannot
' detect that. To diagnose the problem, change AidDebugging from False to True and inspect the
' PowerShell output, which will remain in view until you close its window.

Public Sub RangeToPNG(RangeRef As Range, Destination As String, _
                      Optional TempFile As String = "RangeToPNG.ps1")
Dim WSH As Object
Dim PSCommand As String
Dim WindowStyle As Integer
Dim ErrorCode As Integer
Const WaitOnReturn = True
Const AidDebugging = False ' provide extra feedback about this routine's execution
  ' Create a little PowerShell script to save the clipboard as a .png file
  ' The script is based on a version found on September 13, 2020 at
  '    https://dev59.com/7bLma4cB1Zd3GeqPdZlC
   Open TempFile For Output As #1
   If (AidDebugging) Then ' output some extra feedback
      Print #1, "Set-PSDebug -Trace 1" ' optional -- aids debugging
   End If
   Print #1, "$img = get-clipboard -format image"
   Print #1, "$img.save(""" & Destination & """)"
   If (AidDebugging) Then ' leave the PowerShell execution record on the screen for review
      Print #1, "Read-Host -Prompt ""Press <Enter> to continue"" "
      WindowStyle = 1 ' display window to aid debugging
   Else
      WindowStyle = 0 ' hide window
   End If
   Close #1
  ' Copy the desired range of cells to the clipboard as a bitmap image
   RangeRef.CopyPicture xlScreen, xlBitmap
  ' Execute the PowerShell script
   PSCommand = "POWERSHELL.exe -ExecutionPolicy Bypass -file """ & TempFile & """ "
   Set WSH = VBA.CreateObject("WScript.Shell")
   ErrorCode = WSH.Run(PSCommand, WindowStyle, WaitOnReturn)
   If (ErrorCode <> 0) Then
      MsgBox "The attempt to run a PowerShell script to save a range " & _
             "as a .png file failed -- error code " & ErrorCode
   End If
   If (Not AidDebugging) Then
     ' Delete the script file, unless it might be useful for debugging
      Kill TempFile
   End If
End Sub

' Here's an example which tests the routine above.
Sub Test()
   RangeToPNG Worksheets("Sheet1").Range("A1:F13"), "E:\Temp\ExportTest.png"
End Sub

- Frogrammer-Analyst

---

谢谢您。我已经让它在受保护的工作表上运行，而其他人则不能。而且图像质量也很高。 - amein

顺便问一下，为什么这个脚本会从保存的图像中删除左侧的一小部分？例如：表视图 - https://i.imgur.com/HFrRxod.png。保存的图像变成了：https://i.imgur.com/YWJFjGO.png。 - amein

@amein -- 我猜“为什么……？”的答案是“这是微软的一个漏洞”。我也注意到了这一点——有时候外部单元格边框不会包含在图像中。我通过在目标范围周围添加非常窄的空行和列来解决这个问题，然后将略微扩大的范围（包括空白部分）输出为图像。这样所有有趣的单元格边框都变成了内部边框，因此它们成为了最终图像的一部分。 - Frogrammer-Analyst

谢谢！我明白了！按照建议进行操作，已经解决了这个问题。 - amein