自學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 推薦閱讀: 相关文章 {{#data}} {{title}} {{/data}}