电子表格中已插入了很多的对象，如何将这些对象批量导出到指定的文件夹中，用vba

Question

电子表格中已插入了很多的对象，如何将这些对象批量导出到指定的文件夹中，用vba。
这是chatgpt写的但有问题，并且插入的对象并不一定是图片
folderPath = "C:\ExportedObjects" '设置导出文件夹路径

If Dir(folderPath, vbDirectory) = "" Then '如果文件夹不存在，则创建
MkDir folderPath
End If

i = 1
For Each obj In ActiveSheet.Shapes '遍历所有对象
If obj.Type = msoPicture Or obj.Type = msoOLEControlObject Then '如果是图片或OLE对象
obj.CopyPicture xlScreen, xlPicture '复制对象
With New Picture '创建新的Picture对象
.Paste '粘贴复制的对象
.SaveAs folderPath & "Object" & i & ".jpg" '保存为jpg文件，文件名包含序号
End With
i = i + 1 '增加序号
End If
Next obj

Answer 1

“Devil组”引证GPT后的撰写：
多问几次GPT.
这段代码只能导出图片和OLE对象，无法导出其他类型的对象。如果要导出其他类型的对象，需要修改判断条件和保存方式。

以下是修改后的代码，可以导出所有类型的对象

folderPath = "C:\ExportedObjects" '设置导出文件夹路径

If Dir(folderPath, vbDirectory) = "" Then '如果文件夹不存在，则创建
MkDir folderPath
End If

i = 1
For Each obj In ActiveSheet.Shapes '遍历所有对象
If obj.Type = msoPicture Or obj.Type = msoOLEControlObject Then '如果是图片或OLE对象
obj.CopyPicture xlScreen, xlPicture '复制对象
With New Picture '创建新的Picture对象
.Paste '粘贴复制的对象
.SaveAs folderPath & "Object" & i & ".jpg" '保存为jpg文件，文件名包含序号
End With
i = i + 1 '增加序号
Else '如果是其他类型的对象
obj.Copy '复制对象
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add '创建新工作簿
With newWorkbook.Sheets(1)
.Paste '粘贴复制的对象
.SaveAs folderPath & "Object" & i & ".xlsx" '保存为xlsx文件，文件名包含序号
End With
newWorkbook.Close False '关闭工作簿，不保存修改
i = i + 1 '增加序号
End If
Next obj

这段代码将图片和OLE对象保存为jpg文件，其他类型的对象保存为xlsx文件，文件名包含序号，保存到指定的文件夹中。注意要在循环内创建新的工作簿，避免粘贴的对象覆盖之前保存的对象。保存完文件后要关闭工作簿，不保存修改。