批量提取文件内所有工作簿中照片

哈喽哈哈1

各位大佬们好，麻烦一下你们。  怎么样对文件内的所有excel表格内照片进行提取并保存到“提取的照片”这个文件夹内。   提取的那个照片最好能对区域有要求，因为有的表格里面有两三个照片这种，希望能帮忙解决一下。谢谢了！（结果已经放在提取的照片文件夹内，供理解，提取出来的照片最好清晰度好一点）

3190496160

提取的那个照片最好能对区域有要求
具体什么要求？？？？？？？？？？？？？？？？？

3190496160

Sub 导出图片()
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
lj = ThisWorkbook.Path & "\工艺文件\"
f = Dir(lj & "*.xls*")
t = Timer
Do While f <> ""
    Set wb = Workbooks.Open(lj & f, 0)
    mc = wb.Worksheets(1).[aa3]
    For Each shap In wb.Worksheets(1).Shapes
        If shap.Type = 13 Then
            If shap.TopLeftCell.Row > 33 And shap.TopLeftCell.Column < 27 Then
                shap.Copy  '//复制图片
                With wb.Worksheets(1).ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart  '//建立一个新图片
                    .Parent.Select
                    Application.Wait Now + TimeValue("00:00:01")
                    .ChartArea.Select
                    .Paste  '//将复制的图片放进去
                    .Export ThisWorkbook.Path & "\提取的照片\" & mc & ".png" '//导出为图片格式，如JPG，GIF
                    .Parent.Delete   '//删除自己建立的图片
                End With
            End If
        End If
    Next shap
    wb.Close False
f = Dir
Loop
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
MsgBox "用时：" & Format(Timer - t, "#0.0000") & " 秒"  '//提示所用时间
End Sub

3190496160

xjl565135022

直接另存为网页文件就好，简单粗暴

3190496160

Desktop.rar (659.25 KB, 下载次数: 19)

2024-12-10 09:38 上传

点击文件名下载附件

cai2532

3190496160 发表于 2024-12-10 09:35
Sub 导出图片()
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = Fals ...

厉害，学习了。

哈喽哈哈1

3190496160 发表于 2024-12-10 09:38

谢谢大佬。完全能正常运行。