被老板批word文件太大，50多M，图片都是svg格式，没办法自动压缩，只能一张张改。但不可能全改，所以这个宏将所有图片导出到文件夹中，这样方便检查哪些图片占了大的储存空间，有针对性地压缩特定图片。
使用方法：
- 打开 Word 文档；
- 按
Alt + F11打开 VBA 编辑器； - 点击
插入→模块； - 粘贴上面的代码；
- 按
F5运行； - 选择图片保存文件夹即可。
Sub ExtractAllPicturesFromWord_Fixed() Dim doc As Document Dim fso As Object Dim ws As Object Dim outFolder As String Dim tempFolder As String Dim zipFile As String Dim extractFolder As String Dim mediaFolder As String Dim file As Object Dim i As Long Dim ext As String Dim newName As String Dim cmd As String Set doc = ActiveDocument Set fso = CreateObject("Scripting.FileSystemObject") Set ws = CreateObject("WScript.Shell") If doc.Path = "" Then MsgBox "请先保存当前Word文档，再运行此宏。", vbExclamation Exit Sub End If doc.Save '选择导出文件夹 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "请选择图片导出文件夹" If .Show <> -1 Then Exit Sub outFolder = .SelectedItems(1) End With If Right(outFolder, 1) <> "\" Then outFolder = outFolder & "\" '创建临时文件夹 tempFolder = Environ$("TEMP") & "\WordImageExtract_" & Format(Now, "yyyymmdd_hhnnss") & "\" extractFolder = tempFolder & "unzipped\" fso.CreateFolder tempFolder fso.CreateFolder extractFolder zipFile = tempFolder & "source.zip" '把当前Word文档复制成zip文件 fso.CopyFile doc.FullName, zipFile, True '用PowerShell解压zip cmd = "powershell -NoProfile -ExecutionPolicy Bypass -Command " & _ """Expand-Archive -LiteralPath '" & zipFile & "' -DestinationPath '" & extractFolder & "' -Force""" ws.Run cmd, 0, True mediaFolder = extractFolder & "word\media\" If Not fso.FolderExists(mediaFolder) Then MsgBox "没有找到图片文件。请确认当前文档是 .docx 或 .docm 格式。", vbInformation Exit Sub End If '复制图片到目标文件夹 i = 1 For Each file In fso.GetFolder(mediaFolder).Files ext = fso.GetExtensionName(file.Name) newName = outFolder & "image_" & Format(i, "000") & "." & ext fso.CopyFile file.Path, newName, True i = i + 1 Next file MsgBox "图片提取完成，共导出 " & i - 1 & " 张图片。" & vbCrLf & _ "保存位置：" & outFolder, vbInformation End Sub