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

Question

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

Answer 1

你想试试下面的代码吗？我在很多个月前的某个地方在互联网上找到并使用过。

它使用 Chart 对象的 Export 函数和 Range 对象的 CopyPicture 方法。

参考文献：

• MSDN - Export method as it applies to the Chart object. 将剪贴板保存为图片

• MSDN - CopyPicture method as it applies to the Range object将范围复制为图片

  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
  

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

Answer 3

谢谢大家！我稍微修改了 Winand 的代码以将其导出到用户的桌面，无论谁在使用工作表。我在代码中将我的想法归功于我的想法（感谢凯尔）。

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:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
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

Answer 4

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/

Answer 5

没有图表的解决方案

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

Answer 6

如果您向 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:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
'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

Answer 7

根据 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

Answer 8

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

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

保存剪贴板的 PowerShell 脚本只需要两行，正如 thom schumacher 在Save Image from clipboard using PowerShell 中所指出的那样。

VBA 可以启动一个 PowerShell 脚本并等待它完成，正如 Asam 在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://stackoverflow.com/questions/55215482/save-image-from-clipboard-using-powershell
   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

Answer 9

这给了我最可靠的结果：

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