解决问题：区域过大时截图不全或者缩放导致截图不清晰问题
解决思路：原Excel表格视图放大为400%后再输出为图片
缺点：当图片过长时输出失败
Range("A1:D100").Select
Selection.Copy
Selection.CopyPicture
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
.Parent.Select
.Paste
.Export "C:/VBA输出测试/区域.JPG" '输出文件路径包括文件名
.Parent.Delete '删除表中图
End With
例1将选定区域保存为图片
Sub RangeToPicture()
Application.ScreenUpdating = True
Dim NowZoom As Integer
Dim rng As Range
Dim FilePath As String
Dim FileName As String
Dim var As Variant
NowZoom = ActiveWindow.Zoom '保存当前缩放倍数，缩放4倍后还原
On Error Resume Next '当取消选择时会出错需要继续判断rng是否为空，空则退出
Set rng = Application.InputBox("请选择保存区域！", "提示", "$A$1:$C$5", , , , , 8)
If rng Is Nothing Then
Exit Sub
End If
'
Application.ScreenUpdating = False
'通过文件对话框选择要保存的文件夹
With Application.FileDialog(msoFileDialogSaveAs)
'.Filters.Clear
.AllowMultiSelect = False
.InitialFileName = "IMG" + CStr(Year(Now())) + "-" + CStr(Month(Now())) + "-" + CStr(Day(Now())) _
+ "_" + CStr(Hour(Now())) + "." + CStr(Minute(Now())) + "." + CStr(Second(Now())) + "_"
.Title = "请选择输出文件夹"
If .Show = -1 Then
For Each var In .SelectedItems
FileName = var '获取选择的文件名称
Next
MsgBox FileName ' 保存文件名称
Else
Exit Sub '取消选择则退出
End If
End With
ActiveWindow.Zoom = 400 '先放大4倍
rng.Select
Selection.Copy
Selection.CopyPicture
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
.Parent.Select
.Paste
.Export Replace(FileName, ".xlsx", "") + ".JPG" '去掉默认文件名后缀.xlsx 输出文件路径包括文件名
.Parent.Delete '删除表中图
End With
ActiveWindow.Zoom = NowZoom '恢复倍数
Application.ScreenUpdating = True '打开屏幕更新
MsgBox "保存成功！"
End Sub
