将工作表复制到另一个工作簿时，插入的图像无法显示

Question

在工作簿 A 中，我有一个宏，用于打开只读工作簿 B，将 4 张工作表复制到工作簿 A 中，然后关闭工作簿 B。

其中一张复制的工作表包含两个插入的 .PNG 图像，但这些图像在复制到工作簿 A 后无法显示在工作表上。

将网络文件夹工作簿 B 所在的位置添加到信任中心设置并勾选“高级选项”下的“剪切、复制、与父单元格排序”选项后，我可以看到带有错误消息的图像轮廓

“图像无法显示..可能没有足够的内存..或图像已损坏..”

在复印纸上。

我怀疑这两个错误是否正确，因为如果我手动复制该工作表，图像就会成功显示。

我录制了一个执行此操作的宏并将代码插入到该宏中，但在运行它时却出现上述错误，这表明 VBA 是罪魁祸首。

我还解压缩了工作簿 A xlsx 文件，以确认两个图像都存储在 xlsx 文件中，而不是从其他地方导入。

我考虑编写代码来显式复制和粘贴图像，但在 VBA 中看不到任何方法可以对目标表上我想要粘贴图像的确切位置进行编码。

我在 XP 上运行 Excel 2007。

有什么想法吗？

Answer 1

我一直无法解决复制图像不显示的问题（自从发布以来我发现它们是否正确显示或生成错误消息似乎是随机发生的），但是我已经找到了一个可行的解决方法来删除图像容器然后在复制的纸张上插入文件中的徽标，并将其放置在纸张上。

我修改了在以下位置找到的 VBA 代码：http://www.exceltip.com/st/Insert_pictures_using_VBA_in_Microsoft_Excel/486.html 如下：

Function InsertImageInRange(Image1_Filepath As String, Image2_Filepath As String, TargetSheet As String, TargetCell1 As Range, TargetCell2 As Range)
    ' Insert a picture(s) and resize to fit the TargetCells range
    ' This workaround deletes the image containers and copies in the original logos from file.

    Dim dblTop As Double, dblLeft As Double, dblWidth As Double, dblHeight As Double   
    Dim objImage As Object         

    Sheets(TargetSheet).Select  
    ' Check that images are valid
    bUnexpectedImage = True
    For Each img In ActiveSheet.Shapes
        If img.Name = "Picture 1" Or img.Name = "Picture 22" Then
            img.Delete
        Else
            bUnexpectedImage = False
        End If
    Next
    If bUnexpectedImage = False Then MsgBox ("Unexpected images found.")

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Function
    If Dir(Image1) = "" Then Exit Function

    ' Insert first logo
    Set objImage = ActiveSheet.Pictures.Insert(Image1)
    ' Determine positions
    With TargetCell1
        dblTop = .Top
        dblLeft = .Left
        dblWidth = .Offset(0, .Columns.Count).Left - .Left
        dblHeight = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' Position  & size image
    With objImage
        .Top = dblTop
        .Left = dblLeft + 13
        .Width = dblWidth + 25
        .Height = dblHeight + 15
    End With
    Set objImage = Nothing

    ' Insert second logo, as above...    
End Function

Answer 2

我也遇到过同样的问题。即使删除并重新添加图像也无法解决问题。我的解决方案是将此代码添加到 Workbook_Open 事件中，以通过隐藏和取消隐藏来强制显示活动工作表上的所有图像。 （最初隐藏的任何形状都会恢复为隐藏状态。）

Private Sub Workbook_Open()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.Visible = Not shp.Visible
        shp.Visible = Not shp.Visible
    Next
End Sub