使用VBA代码如何在Excel 2003中将Excel工作表导出为图像？
请build议从excel工作表中导出数据范围的更好方式，如.jpeg或.png或.gif中的图像。
你想尝试下面的代码，我在互联网上find许多月以前的地方和使用。
它使用Chart对象的Export函数以及Range对象的CopyPicture方法。
参考文献：
- 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
我试图用几种方法来改进这个解决scheme。 现在形成的图像具有正确的比例。
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的代码，将其导出到用户的桌面，不pipe是谁在使用工作表。 我在代码中给了我认识的地方（谢谢凯尔）。
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
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/
基于菲利普提供的链接，我得到了这个工作
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
解决scheme没有图表
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
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
如果您添加一个select并保存到工作簿pathRyan 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
