VBA代码能再Excel2016版本上完美运行，为什么在Excel 365版本上却运行不.

thomasxian84

我有一个大的表格，里面有几百张图片，需要把Excel里的图片都导出来保存在文件夹里，并且图片要根据表格里图片对应到A列单元格的值来给图片命名，所以写了个VBA代码来完成，代买如下：

Sub exportpictures()

Dim i As Long

Dim pic

Dim p As String

Dim path As String

path = InputBox("请输入要保存图片的路径：", "保存路径", ThisWorkbook.path)

  For i = 1 To Sheet1.Shapes.Count

    Set pic = Sheet1.Shapes(i)

     If pic.Type = 11 Or pic.Type = 13 Then

        pic.Name = pic.TopLeftCell.Offset(0, -1).Value

        p = path & "\" & pic.Name & ".jpg"

        pic.CopyPicture

        With ActiveSheet.ChartObjects.Add(0, 0, pic.Width, pic.Height).Chart

          .Paste

          .Export p, "jpg"

          .Parent.Delete

        End With

    End If

  Next

End Sub

本来这个代码是在家里摸索了半天倒腾出来的，家里的Excel版本是2016版，试过了也可以完美运行，但是回到公司，用的是Excel 365版本，反而是运行不了。主要出现几个问题：

1. 报错：“copypicture”方法作用于对象“shape”时失败“, 改成copy也不行。

2. 用On Error Resume Next 语句强行运行，部分图片导出来后，打开是一片空白的，没有图像在里面，但在2016版本上是没这个问题的。

搞了半天，实在搞不定，只能上来这里，请教一下各位大神，看看有没有办法可以完美解决呢？或者那个大神能够提供另外一个办法能够把图片完美导出的，谢谢

附上简化后的附件。

无敌小猪猪

好像要把这个打开，你试试

vistababy

楼主，代码在excel2013也不起作用呢。。也不出错，也不导出图片。你的文件、我的文件，都试过
我用代码MsgBox Sheet1.Shapes.Count查了下，显示0，说明找不到图片。

taller

thomasxian84

vistababy 发表于 2023-4-1 11:09
楼主，代码在excel2013也不起作用呢。。也不出错，也不导出图片。你的文件、我的文件，都试过
我用代码Msg ...

那我也不太清楚是哪里出问题了，但这个代码，我再2016是可以的，这个“shape"的图形的语句，感觉是各个版本都会改还是怎么回事，头疼。。

thomasxian84

taller 发表于 2023-4-1 12:52

谢谢大神，我等下去试一下，哈哈

vistababy

thomasxian84 发表于 2023-4-2 15:50
那我也不太清楚是哪里出问题了，但这个代码，我再2016是可以的，这个“shape"的图形的语句，感觉是各个版 ...

楼主，问题解决了，我把所有的sheet1改成ActiveSheet就没有问题了。
但拿你的文件做试验，导出图片只有2张，一个是：连衣裙.jpg，另一个是：长裤.jpg，原来是因为你的类目只有连衣裙、长裤，导致另外3张图片导出时覆盖，所以我改了一下代码，增加了“款号”在后面，就能导出5张图片了。 同时参考了4楼的意见加了一行代码。完美了！
另外，我还改了下你的保存路径为：ActiveWorkbook.path，这样才能对应xls文件所有目录，否则thisworkbook.path每次都指向了C:\Users\用户名\AppData\Roaming\Microsoft\Excel\XLSTART这个文件夹，感觉不太对。


Sub 导出所有图片()
On Error Resume Next


Dim i As Long
Dim pic
Dim p As String
Dim path As String

path = InputBox("请输入要保存图片的路径：", "保存路径", ActiveWorkbook.path)

  For i = 1 To ActiveSheet.Shapes.Count
    Set pic = ActiveSheet.Shapes(i)
     If pic.Type = 11 Or pic.Type = 13 Then
        pic.Name = pic.TopLeftCell.Offset(0, -1).Value & pic.TopLeftCell.Offset(0, -3).Value
        p = path & "\" & pic.Name & ".jpg"
        pic.CopyPicture
        With ActiveSheet.ChartObjects.Add(0, 0, pic.Width, pic.Height).Chart
          .Parent.Select
          .Paste
          .Export p, "jpg"
          .Parent.Delete
        End With
    End If
  Next
End Sub

vistababy

7楼的代码是没有问题了，但我又发现了一个问题，就是导出图片的大小和当时Excel的视图显示比例有关，把表格界面缩小，导出的图片就很小，才几KB，和蚂蚁一样。
你们不信试一下，把页面显示比例设置为25%，再运行上面的程序，导出的图片只有几KB。
而我用另存为网页的方式，进文件夹看，里面的图片尺寸、文件大小都是大很多的。所以有问题。
于是我想到了很奇怪的一招。就是导出前将显示比例调为400%，图片大多了。完美！

vistababy

当然想更省事的话，可以在for i=1那句前面加上：

Application.ScreenUpdating = False
oldzoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 400


在保存完后的最末尾一行Next后面加上：

Application.ScreenUpdating = True
ActiveWindow.Zoom = oldzoom


就更完美了。不但速度快了，而且看不到任何界面缩放的变化。

vistababy

我还有方法2，就是在导出前将图片放大，导出后缩小。图片也能变大变清晰一些。对排版没有影响。


代码如下图，导出前放大5倍，导出后缩小5倍，等于还原。记得显示比例到400%的代码要取消。