求助：VBA批量无损导出图片，找遍全网也没找到答案

ii_snow · 发表于 2023-3-22 22:54

本帖最后由 ii_snow 于 2023-3-22 23:02 编辑

由于工作原因，需要批量导出表格图片，并按编号命名，按很多前辈的方法使用ChartObjects方法使用了一段时间，但是发现几个问题：

1、导出的图片即使放大倍数，改换存储格式（JPG，PNG都试过），图片导出的分辨率比使用另存为原始图片（365有了另存为图片的功能）仍然压缩了很多(不同来源的图片差异不同，但是经实践证实使用ChartObjects放大后图片不少比原始图片模糊很多）。
2、使用ChartObjects方法，只能Export一种图片格式，而使用另存为时会发现，有些图片原始出处是JPG，有些是PNG。。。
我从去年就开始寻求方法，但是至今只能实现批量导出图片，一直没有找到VBA批量无损导出图片的方法，跪求大神慷慨出手解决！
附件已有常规导出的VBA,希望高手给出无损导出的方法，感谢！

附文件中的代码：

Sub 批量保存B列中的图片() '按A列名称导出B列图片
Dim shp As Shape '定义shp为图形对象
Application.ScreenUpdating = False '禁止屏幕刷新
Application.DisplayAlerts = False '关闭显示警告
On Error Resume Next '代码出错继续执行
Dim pth As String '定义路径变量
pth = ActiveWorkbook.Path & "" & "测试导出图片" & "" '定义文件夹路径和名称
If Len(Dir(pth, vbDirectory)) > 0 Then '生成存放图片的文件夹
MsgBox "文件夹" & pth & "已存在"
Else
MkDir pth '生成文件夹
End If
N = 0
For Each shp In ActiveSheet.Shapes '把当前表格里的每个图形赋值给shp
If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Or shp.Type = msoAutoShape Or shp.Type = msoChart Then '条件格式：判断shape的类型是否图片，（可以用值13代替msoPicture）
Set Rng = shp.BottomRightCell '赋值RNG为图片所在的单元格
If Rng.Row <= 600 And Rng.Column = 2 Then '设定图片范围600张以内，图片位于B列
N = N + 1
iH = shp.Height '保留已编辑的高度
iW = shp.Width '保留已编辑的宽度
shp.ScaleHeight 1, msoCTrue '重置B列中的图片shp到原始高度
shp.ScaleWidth 1, msoCTrue '重置B列中图片shp到原始宽度
shp.CopyPicture xlPrinter, xlPicture '复制此图片到剪切板
With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '在工作表中添加一个绘图框临时存放图片
.Parent.Select '选择单元格中的图片对象
.Paste '粘贴到临时的绘图框中
.Parent.Width = shp.Width * 2
.Parent.Height = shp.Height * 2
.Export (pth & Range(Rng.Address).Offset(0, -1) & ".PNG") '导出图片到同目录的“导出图片”文件夹，并以A列名重命名
.Parent.Delete '删除临时绘图框
shp.Height = iH
shp.Width = iW
End With
End If
End If
Next
MsgBox "图片共" & N & "张已导出到" & pth & "文件夹中！请前往查看：）"
Application.ScreenUpdating = True '允许屏幕刷新
Application.DisplayAlerts = True '开启显示警告
End Sub

复制代码

约定的童话 · 发表于 2023-3-23 07:22

Sub BatchExportPictures()
Dim path As String
Dim folder As Object
Dim file As Object
Dim i As Integer

path = "C:\Pictures\" '图片所在文件夹路径

Set folder = CreateObject("Scripting.FileSystemObject").getfolder(path)

For Each file In folder.Files
      If Right(file.Name, 4) = ".jpg" Or Right(file.Name, 5) = ".jpeg" Or Right(file.Name, 4) = ".png" Or Right(file.Name, 4) = ".bmp" Then '判断文件是否为图片类型
         i = i + 1
         ActiveSheet.Shapes.AddPicture Filename:=file.Path, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
            Left:=ActiveSheet.Cells(i, 1).Left, Top:=ActiveSheet.Cells(i, 1).Top, Width:=100, Height:=100 '导入图片到Excel中
      End If
Next file

'将Excel中的图片（无损）批量导出到指定文件夹
ActiveSheet.Shapes.Range(Array(1, 1, i, 1)).Export "C:\ExportedPictures\", ppSaveAsPNG
End Sub

liulang0808 · 发表于 2023-3-23 07:47

另存为网页文件看看是否可行

ii_snow · 发表于 2023-3-23 08:47

liulang0808 发表于 2023-3-23 07:47
另存为网页文件看看是否可行

目的是用vba导出所有图片，并且指定文件名和位置，不知道另存为网页文件也可以用vba做到这些吗？请问如何用vba操作？

ivccav · 发表于 2023-3-23 09:29

本帖最后由 ivccav 于 2023-3-23 09:34 编辑

你用的这种方式导出图片，质量非常差，不是原图。我尝试过复制图片到剪贴板，然后用API从剪贴板保存为图片，也不行。可用解压缩软件打开Excel，里面的图片都是原图，但不知道对应文件名。

perfect131 · 发表于 2023-3-23 11:51

ii_snow 发表于 2023-3-23 08:47
目的是用vba导出所有图片，并且指定文件名和位置，不知道另存为网页文件也可以用vba做到这些吗？请问如何 ...

可以的
https://club.excelhome.net/thread-1648005-1-1.html
你这个有点不同，有组合，还需要utf8读取

perfect131 · 发表于 2023-3-23 12:08

按图片名称导出的

ivccav · 发表于 2023-3-23 14:17

perfect131 发表于 2023-3-23 12:08
按图片名称导出的

不是要图片在Excel的shape.name名称，而是要能指定图片名称进行导出，即根据图片左上角或者右下角单元格信息，推导出时指定一个名称。据说htm只适用于Excel，WPS是无法得到图片。目前通用的方法是用压缩软件打开Excel文件获得图片。至于图片名称，可以先循环shape对象的名称，然后跟想要的名称形成一个对照表。

ii_snow · 发表于 2023-3-23 16:05

ivccav 发表于 2023-3-23 14:17
不是要图片在Excel的shape.name名称，而是要能指定图片名称进行导出，即根据图片左上角或者右下角单元格 ...

我原来那个代码就是按指定图片名称导出的，但是分辨率太差，楼上说的我晚上回去再仔细研究一下，理论上来说，我那个原代码只要把导出图片这部分内容改掉就可以用了，关键问题就是怎么样导出能保证分辨率

tspliu · 发表于 2023-3-23 16:05

输出的三个分别对应自上而下三个图片

		自动登录	找回密码
密码			免费注册

[求助] 求助：VBA批量无损导出图片，找遍全网也没找到答案