截取图片错误内存不足_自学VBA——excel截图保存并规避1004错误

背景

本人用excel做了一份数据分析报表，通过在切片器中选定参数，报表可展示出不同的图表。为了方便图表间的对比，在报表中设置了截图按钮（图中的照相机）并指定对应的vba宏；通过点击截图按钮，可将报表中的内容以图片形式保存到新的工作表中；然后使用Ctrl+PageUp/PageDown快捷键，就可以在这些工作表之间来回切换，达到类似动图的效果，从而方便对比不同参数影响下的图表。

遇到问题

按照原始的截图代码，很容易没截几张图，就会弹出运行错误警告，令人十分不愉快（尽管退出后重新点击截图按钮，还是可以截图成功）。

　　更具体来说：
　　1、该警告窗口只能通过点击"结束"按钮才能退出；
　　2、如果点击"调试"按钮或按下Enter键，则会跳转vba编辑窗口；
　　3、无法通过Esc或Enter等用户常用键快速退出，必须移动鼠标点击"结束"按钮。

　　如果该报表只是自己用，麻烦点就算了；但如果给导师用，面对不停弹出的错误警告.....那我死定了┗|｀O′|┛ 嗷~~

Sub 原始截图代码()

    Application.CutCopyMode = False
    Application.Worksheets("报表").Range("A1:AC36").CopyPicture xlScreen, xlBitmap
    Sheets.Add After:=ActiveSheet
    ActiveWindow.Zoom = 75
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("A1").Select
    
End Sub

问题原因

　　依照网站上的提示和自己的试错，发现是电脑在执行前两行代码时，往往会反应不过来，也即无法清空剪切板或复制区域图片，从而使程序报错。尤其对我那既有数据透视表/图、切片器，又有各种公式、形状、图片的报表，电脑反应不过来是常有的事。

　　附一个网站上的更专业解释：http://www.itdaan.com/blog/2014/07/14/6bed50193bf41277534633675fe764a2.html

假设，似乎有理由认为，在缓慢或负载很重的计算机上，Excel会对页面上的复杂对象进行“延迟处理”，即在以某种方式访问​​对象之前不会对其进行渲染。强制渲染的一种方法似乎是在Visible = 1模式下运行。另一种方法是循环遍历对象。如果是这种情况，那么它是Excel的CopyPicture实现的一个错误，它不会在尝试复制之前强制复制对象。当复制方法发现目标范围的渲染尚未就绪时，它只会抛出错误而不是强制渲染范围。好吧，至少那是我的理论。

解决方案

一切尽在以下的代码中，效果是基本连续截图都不会报错，万一报错也可Esc/Enter快速退出重来。各位可直接复制到excel宏模块中体验使用。
　　另注启发来源：PctGL的发言https://bbs.csdn.net/topics/390865179
　　找了一下午的，感谢PctGL！！

Sub 截图保存()

'程序运行效果：截取当前工作表的某个区域，并在新建工作表中以图片形式保存（且工作表调整为某缩放比例），然后返回刚被截图的工作表中。
'程序代码逻辑：一次截图失败，那就再截图一次；如果还是失败，那就弹窗提示好了（该弹窗可Esc/Enter快速退出）。
    
'【参数设定区】设定当前工作表的截图区域和所存工作表的缩放比例

    PSR = "A1:AC36"      'PSR = Print Screen Range
    SWZ = 75            'SWZ = Save Window Zoom

'【核心代码区】

On Error GoTo try_again
    Application.CutCopyMode = False
    Application.ActiveSheet.Range(PSR).CopyPicture xlScreen, xlBitmap
    Sheets.Add After:=ActiveSheet
    ActiveWindow.Zoom = SWZ
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Exit Sub
    
try_again:
    On Error GoTo -1
    On Error GoTo give_up
    Application.CutCopyMode = False
    Application.ActiveSheet.Range(PSR).CopyPicture xlScreen, xlBitmap
    Sheets.Add After:=ActiveSheet
    ActiveWindow.Zoom = SWZ
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Exit Sub

give_up:
    On Error GoTo -1
    On Error GoTo give_up
    MsgBox "系统繁忙，请重新截屏。"
    Exit Sub
    
End Sub