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

Using VBA code, how to export Excel worksheets as image in Excel 2003?

提问by Vishal I Patil

Please suggest the better way of exporting range of data from excel worksheets as image either in .jpeg or .png or in .gif.

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

采纳答案by Our Man in Bananas

do you want to try the below code I found on the internet somewhere many moons ago and used.

你想试试我在很多个月前在互联网上找到并使用的以下代码吗？

It uses the Export function of the Chart object along with the CopyPicture method of the Range object.

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

References:

参考：

• 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 objectto 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
  

• MSDN - 导出方法，因为它适用于 Chart 对象。将剪贴板保存为图像

• MSDN - CopyPicture 方法，因为它适用于 Range 对象以将范围复制为图片

  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
  

回答by Winand

I've tried to improve this solution in several ways. Now resulting image has right proportions.

我尝试以多种方式改进此解决方案。现在生成的图像具有正确的比例。

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

回答by Ryan Bradley

Thanks everyone! I modified Winand's code slightly to export it to the user's desktop, no matter who is using the worksheet. I gave credit in the code to where I got the idea (thanks Kyle).

谢谢大家！我稍微修改了 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

回答by Leonardo Mezavilla

Solution without charts

没有图表的解决方案

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

回答by ?ukasz Ma?arzewski

If you add a Selection and saving to workbook path to Ryan Bradley code that will be more elastic:

如果您向 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

回答by MartinC

Winand, Quality was also an issue for me so I did this:

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

See here:https://robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/

请参阅此处：https: //robp30.wordpress.com/2012/01/11/improving-the-quality-of-excel-image-export/

回答by ambassallo

Based on the link provided by Philip I got this to working

根据菲利普提供的链接，我开始工作了

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

回答by ZygD

This gives me the most reliable results:

这给了我最可靠的结果：

Sub RangeToPicture()
  Dim FileName As String: FileName = "C:\file.bmp"
  Dim rPrt As Range: Set rPrt = ThisWorkbook.Sheets("Sheet1").Range("A1:C6")

  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
End Sub