Question

虽然这种经过验证的方法对人们起作用并且在一般意义上对我有用，但我收到了＃34;错误1004：方法＆＃39;粘贴＆＃39;对象＆＃39; _Chart＆＃39;失败＆＃34。但是，在循环的第5次迭代中，发生此方法失败。我已经尝试隔离数组的每个组件，第6和第7个元素总是失败，但是当第5个元素被单独使用或作为循环的起点时它成功。我还尝试在流程的不同阶段清除剪贴板，看看是否有助于并测试＆＃34; cht＆＃34;的对象属性。对象

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

您是否尝试使用剪贴板查看器验证rgExp.CopyPicture操作是否已按照Debug.Print x显示5（第6次迭代）时的预期进行操作？

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

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

Answer 2

确定。我发现了这个问题。图表必须包含在可由剪贴板粘贴的可视屏幕中。所以你可以缩小（不理想，因为图像保存得很小并因此像素化）或缩放到新的图表区域/选择图表对象放在首位的位置。我的解决方案是缩放到范围。调整后的代码如下。希望这有助于其他人：）

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

上面调用的ZoomToRange宏如下：

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

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

2 个答案: