当可视屏幕区域外，粘贴图表失败

虽然这种已被证实的方法已经为人们工作，并在一般意义上为我工作，但我收到“错误1004：Method'Paste'对象'_Chart'失败。 但是，在循环的第5次迭代中，会发生此方法失败。 我试图隔离数组中的每个组件，并且第6和第7个元素总是失败，但是当第5个元素被隔离使用或作为循环的起点成功时。 我也尝试在进程的不同阶段清除剪贴板，以查看是否有助于并testing“cht”对象的对象属性。

Sub PicturesCopy() 'Define path variables Path = "C:\Users\khill\Documents\Macro Tests\" PathSC = Path & "Master Cockpit\" FileMCP = "Master_Daily sales cockpit.xlsm" Set wbMCP = Workbooks(FileMCP) Dim cht As ChartObject Dim rngList, fileList As Variant rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139") fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b") For x = 0 To UBound(rngList) 'Application.CutCopyMode = True With wbMCP.Worksheets("Graphs") Debug.Print rngList(x) Dim rgExp As Range: Set rgExp = .Range(rngList(x)) Debug.Print x rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture End With ''' Create an empty chart with exact size of range copied Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _ Width:=rgExp.Width, Height:=rgExp.Height) cht.Name = "PicChart" With cht .Chart.Paste Debug.Print fileList(x) .Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg" .Delete 'Application.CutCopyMode = False End With Set cht = Nothing Set rgExp = Nothing Next x End Sub 

Answer 1

您是否尝试过使用剪贴板查看器来validation当Debug.Print x显示5（第6次迭代）时， rgExp.CopyPicture操作已经完成了您所期望的操作？

假设你正在使用某个版本的Windows，这里有一些关于如何查看剪贴板的提示，具体取决于版本：

在Windows 10/8/7中查看和pipe理剪贴板
http://www.thewindowsclub.com/windows-clipboard-manager-viewer

Answer 2

好。 我发现了这个问题。 图表必须包含在可见屏幕内才能被剪贴板粘贴。 所以你可以缩小（不理想，因为图像保存得很小，因此像素化），或者放大到新的图表区域/select放置图表对象的位置。 我的解决scheme是放大到范围。 调整后的代码如下。 希望这可以帮助别人:)

 Sub PicturesCopy() 'Define path variables Path = "C:\Users\khill\Documents\Macro Tests\" PathSC = Path & "Master Cockpit\" FileMCP = "Master_Daily sales cockpit.xlsm" Set wbMCP = Workbooks(FileMCP) Dim cht As ChartObject Dim rngList, fileList As Variant rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139") fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b") For x = 0 To UBound(rngList) 'Application.CutCopyMode = True With wbMCP.Worksheets("Graphs") Debug.Print rngList(x) Dim rgExp As Range: Set rgExp = .Range(rngList(x)) Debug.Print x rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture End With ''' Create an empty chart with exact size of range copied Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _ Width:=rgExp.Width, Height:=rgExp.Height) cht.Name = "PicChart" 'Use ZoomToRange sub to re-size the window as appropriate ZoomToRange ZoomThisRange:=Range(rngList(x)), PreserveRows:=True With cht .Chart.Paste Debug.Print fileList(x) .Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg" .Delete 'Application.CutCopyMode = False End With Set cht = Nothing Set rgExp = Nothing Next x End Sub 

上面调用的ZoomToRangemacros如下所示：

 Sub ZoomToRange(ByVal ZoomThisRange As Range, _ ByVal PreserveRows As Boolean) '################################### 'This macro resizes the window and'' 'zoom properties to be appropriate'' 'for our use'''''''''''''''''''''''' '################################### 'Turn alerts and screen updating off Application.DisplayAlerts = False Application.ScreenUpdating = False 'Declare variable type Dim Wind As Window 'Create variable for window Set Wind = ActiveWindow 'Zooming to specified range set to true Application.GoTo ZoomThisRange(1, 1), True 'Select the resized range With ZoomThisRange If PreserveRows = True Then .Resize(.Rows.Count, 1).Select Else .Resize(1, .Columns.Count).Select End If End With 'Set zoom and visible range to specified range With Wind .Zoom = True .VisibleRange(1, 1).Select End With End Sub