提取word所有图片至特定文件夹-宏命令

被老板批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