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

ykcbf1100

1. Sub 批量保存B列中的图片() '按A列名称导出B列图片
   
2.     Dim shp As Shape '定义shp为图形对象
   
3.     Dim pth As String '定义路径变量
   
4.     Dim N As Long
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     On Error Resume Next
   
8.     pth = ActiveWorkbook.Path & "" & "测试导出图片" & ""
   
9.     If Len(Dir(pth, vbDirectory)) = 0 Then MkDir pth
   
10.     N = 0
    
11.     For Each shp In ActiveSheet.Shapes '把当前表格里的每个图形赋值给shp
    
12.         If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Or shp.Type = msoAutoShape Or shp.Type = msoChart Then
    
13.             Set Rng = shp.BottomRightCell '赋值RNG为图片所在的单元格
    
14.             If Rng.Row <= 600 And Rng.Column = 2 Then '设定图片范围600张以内，图片位于B列
    
15.                 N = N + 1
    
16.                 ' 直接导出图片，保持原始格式
    
17.                 shp.Export pth & Range(Rng.Address).Offset(0, -1) & "." & GetPictureFormat(shp)
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     MsgBox "图片共" & N & "张已导出到" & pth & "文件夹中！请前往查看：）"
    
22.     Application.ScreenUpdating = True
    
23.     Application.DisplayAlerts = True
    
24. End Sub
    
25. 
    
26. ' 辅助函数：获取图片格式
    
27. Function GetPictureFormat(shp As Shape) As String
    
28.     Select Case shp.Type
    
29.         Case msoPicture, msoLinkedPicture
    
30.             On Error Resume Next
    
31.             Dim picFormat As String
    
32.             picFormat = shp.AlternativeText
    
33.             If InStr(1, picFormat, ".") > 0 Then
    
34.                 GetPictureFormat = Mid(picFormat, InStrRev(picFormat, ".") + 1)
    
35.             Else
    
36.                 GetPictureFormat = "png"
    
37.             End If
    
38.             On Error GoTo 0
    
39.         Case Else
    
40.             GetPictureFormat = "png"
    
41.     End Select
    
42. End Function
    

复制代码

阿法尔二

直接用zip解压就行了呢

morpheus126

shape的名称，也就是窗格里那个，没什么用的，因为是允许重复的
至于放大，不管多大，都已经污染了

zhumin1025

高度保密 发表于 2023-5-21 10:13
我这里win7，excel2016，导出不成功，显示导出0张图片

同样的问题

zhumin1025

ykcbf1100 发表于 2025-11-26 19:18
借题练习，无损导出图片

win11  excel2024，没有导出文件