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的代码，无论是谁在使用工作表，都将其导出到用户的桌面。我在代码中赞美了我的想法（感谢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:
'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

基于菲利普提供的链接我得到了这个工作

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

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 9

这给了我最可靠的结果：

snowflake_sample_data

Answer 10

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

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

如Save Image from clipboard using PowerShell中的thom schumacher所述，用于保存剪贴板的PowerShell脚本仅需要两行。

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

将这些想法综合在一起，我们得到以下例程。我仅在使用Office 2010版本的Excel的Windows 10下对此进行了测试。请注意，有一个内部常量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

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

10 个答案: