Question

我编写的程序从工作簿中的各种来源读取信息，将信息重新排列到单独的工作表上的几个紧凑表中，然后将这些表作为图像复制到单独的摘要表中。我已将此程序编写为主程序调用的几个不同的子程序。

当主程序运行时，它粘贴到摘要表中的图像具有正确的尺寸和位置，但它们是完全白色的。但是，当我运行负责复制这些图像的子例程时，它成功地实际复制了正确的表。这是我用来复制和过去表格的代码，如图像：

Sub ExtractToPresentation()

Call UnprotectAll

Application.DisplayAlerts = False

Application.CutCopyMode = False

startcell = Worksheets("Supplier Comparison").Cells(1, 1).Address
bottomcell = Worksheets("Supplier Comparison").Cells(21, 14).Address

Set copyrng = Worksheets("Supplier Comparison").Range(startcell, bottomcell) '.SpecialCells(xlCellTypeVisible)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(SupSt)

End With

子例程继续，但其余部分是每个附加表的上述代码的变体：

startcell = Worksheets("Rating Criteria").Cells(1, 1).Address
bottomcell = Worksheets("Rating Criteria").Cells(12, 7).Address

Set copyrng = Worksheets("Rating Criteria").Range(startcell, bottomcell)
copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CritSt)

End With

startcell = Worksheets("Comments").Cells(1, 1).Address
bottomcell = Worksheets("Comments").Cells(4, 14).Address

Set copyrng = Worksheets("Comments").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CommSt)

End With

startcell = Worksheets("Component Table").Cells(1, 1).Address
bottomcell = Worksheets("Component Table").Cells(CompH, CompW).Address

Set copyrng = Worksheets("Component Table").Range(startcell, bottomcell)

copyrng.CopyPicture xlScreen, xlBitmap

With Worksheets("Presentation")

    .Paste _
        Destination:=.Range(CompSt)

End With

Application.DisplayAlerts = False

Call ProtectAll

End Sub

以St，H和W结尾的变量在先前的程序中定义，该程序确定每个表的大小。我不知道为什么这个程序可以完全独立运行，但在其他程序之后运行时返回空白图像。

如果有人想查看我的代码的其他部分，请告诉我。这个程序中有大约500行，我不想一下子全部转储。

Answer 1

再次application.screenupdating = true displayalert - true，看看它是否有效。

我在将对象从excel复制到PPT时遇到了同样的问题，当我创建screeupdating = true（默认）时，它开始工作： - ）

Swarup

Answer 2

尝试

Range(*source*).Copy                           ' full source range

' asume you have a destination cell as a range
*destination*.Parent.Select                    ' select sheet
*destination*.Select                           ' select dest cell
*destination*.Parent.Pictures.Paste            ' paste

如果您需要调整图像大小，请使用

*sheet*.Shapes(x).Height
*sheet*.Shapes(x).Width

工作示例：

Sub Test()
    Set src = Sheets("Sheet1").Range("A1", "B4")
    Set dst = Sheets("Sheet2").[C5]
    src.Copy
    dst.Parent.Select
    dst.Select
    dst.Parent.Pictures.Paste
    src.Parent.Select
    src.Select
End Sub

Answer 3

我从几个文件中插入超过3.000个图片，有时也会出现此问题。我可以通过在插入和放置图片后立即插入一个短暂的休息[Sleep（25）]然后插入[DoEvents]来解决问题。不需要ScreenUpdating ......

错误修复：Excel VBA中的复制图像显示为空白图像

3 个答案: