如题，总有小伙伴喜欢在excel中插入图片，弄个产品手册之类的。殊不知这玩意看着挺爽，弄到其他系统里却挺麻烦。
好几百兆的表格打开慢，好几百张图片，导出来也费劲。请教gpt反反复复，改来改去，弄出一套可用的代码。留着以后用。
代码如下
Sub ExportImagesWithCustomFilenameAndStretch()
Dim shp As Shape
Dim ws As Worksheet
Dim imgPath As String
Dim i As Integer
Dim exportWidthPx As Double
Dim exportHeightPx As Double
Dim exportWidthPt As Double
Dim exportHeightPt As Double
Dim imgCell As Range
Dim fileName As String
' 设置导出的图片宽高（以像素为单位）
exportWidthPx = 600 ' 设置导出的图片宽度（像素）
exportHeightPx = 800 ' 设置导出的图片高度（像素）
' 将像素转换为磅，1像素 ≈ 0.75磅
exportWidthPt = exportWidthPx * 0.75
exportHeightPt = exportHeightPx * 0.75
' 设置导出的文件夹路径
imgPath = "C:\ExportedImages\" ' 请根据需要更改路径
' 如果文件夹不存在，则创建
If Dir(imgPath, vbDirectory) = "" Then
MkDir imgPath
End If
' 获取当前工作表
Set ws = ThisWorkbook.Sheets(1) ' 修改为你想要导出的工作表
' 遍历所有图片并导出
For Each shp In ws.Shapes
If shp.Type = msoPicture Then
' 获取图片所在的单元格
Set imgCell = shp.TopLeftCell
' 读取该行第N列（我们的表在16列）的文件名
fileName = ws.Cells(imgCell.Row, 16).Value ' B列
' 检查文件名是否为空，防止导出时出错
If Trim(fileName) = "" Then
fileName = "Image_" & i ' 若文件名为空，使用默认文件名
End If
' 强制拉伸图片到指定的宽高
shp.LockAspectRatio = msoFalse ' 取消保持宽高比
shp.Width = exportWidthPt
shp.Height = exportHeightPt
' 导出图片
shp.Copy
' 创建临时图表，并将其大小设置为导出的尺寸
With ws.ChartObjects.Add(0, 0, exportWidthPt, exportHeightPt)
.Activate
.Chart.Paste
' 将图片导出到指定路径，使用从第二列读取的文件名
.Chart.Export imgPath & fileName & ".jpg"
' 删除临时图表
.Delete
End With
i = i + 1
End If
Next shp
MsgBox "图片导出完成，保存于: " & imgPath
End Sub
excel宏vba不熟悉的可以参考这个步骤
步骤：
如何运行：
- 在Excel中按
Alt + F8，选择ExportImagesWithSize并点击“运行”。 - 该宏将遍历当前工作表中的所有图片，调整它们的大小并导出到指定文件夹。
注意事项：
- 导出的图片格式是
.jpg，你可以根据需要将其更改为.png或其他格式。 - 文件路径必须是有效的，你需要确保文件夹存在或代码中设置的路径可以访问。
特别提示
记得备份表格，此代码会批量调整表格中的图片大小。把调好的缩咯图，变成指定尺寸的图。
大图会重叠。虽然可以通过代码再跑一遍，缩回原来的尺寸。不过我觉得再来一遍不如删掉省事。
关于运行报错的问题，比如出现错误 -2147319780 (8002801c) 及“自动化访问系统注册表错误”
这通常意味着某些必要的COM组件或库在系统中未正确注册，或者Excel与外部应用程序（如Word）之间的自动化功能存在问题。
下面就要开启各种库和组件。微软就是这么麻烦。
还好我们有wps
懒得折腾可以试试wps表格，以上代码同样可以执行。
如果实在不会
还有笨办法，表格另存为html网页文件。不过这种表格里的图片什么尺寸，导出来的就是什么尺寸。小图不能变大图。
