通过VBA导出word文档中的图片

一、问题重述：

工作中，经常有同事把新闻的照片贴在word文档中发过来，需要把照片一张张的转存成图片。

二、原始方法：

1. 在文档中的照片上，右键，图片另存为……
2. 把文档，按F12，另存为网页文件，然后在生成的文件夹中，去找（注意，要忽略同名的缩略图）
3. 把docx文件直接改为zip文件，解压，在解压后的文件里面，去找照片。

三、VBA思路

• 1.存储当前文档的完整名称：方便之后重新打开
• 2.在文档的同一目录下，以word文件名，新建一个文件夹，如“XXXX文档_图片”。
• 3.保存当前文档，然后另存一份来操作。  
• 4.设置zip文件名，文档副本同名
• 5.把docx文件命名为zip文件 
• 6.解压另存的zip文件
• 7.收拾收拾，把导出的图片移动出来，同时删除第6步建立的文件夹，删除zip文件
• 8.打开图片文件所在目录

四、实现效果

会在当前文档的目录下，建一个文件夹，然后把导出的图片，存在在此文件夹里面。

五、原代码奉上，欢迎大家提出意见或修改的建议

Option Explicit
'批量导出单张图片
Sub ExtractPicture()
    Dim docFullName As String
    '1.存储当前文档的完整名称：方便之后重新打开
    docFullName = Word.ActiveDocument.FullName
    '2.在文档的同一目录下，以word文件名，新建一个文件夹，如“XXXX文档_图片”用于保存导出的照片及后面的一些临时文件
    Dim fileSavePath As String
    fileSavePath = ActiveDocument.Path & "\" & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & "_图片\"
    If Dir(fileSavePath, vbDirectory) = "" Then MkDir (fileSavePath) '如果文件夹不存在，就新建一个

    Word.Application.ScreenUpdating = False '关闭屏幕刷新
    '3.保存当前文档，然后另存一份来操作。
    ActiveDocument.Save   '保存当前文档
    Dim CopyFileFullName As String
    Dim saveAsFileName As String
    saveAsFileName = Format(Now, "yyyymmddhhmmss")
    Word.ActiveDocument.SaveAs2 fileName:=fileSavePath & saveAsFileName & ".docx"
    CopyFileFullName = fileSavePath & saveAsFileName & ".docx"   '将副本的文件完整路径临时存储，方便之后调用解压
    Word.ActiveDocument.Close '关闭另存为后的文档，打开源文档
    Word.Documents.Open docFullName
    '4.设置zip文件名，文档副本同名
    Dim zipFullName As Variant  '使用变体变量
    zipFullName = fileSavePath & saveAsFileName & ".zip"
    '5.把docx文件命名为zip文件
    Name CopyFileFullName As zipFullName

    '6.解压另存的zip文件
    Dim strDate As String, FileNameFolder As Variant
    '创建一个文件夹来装临时文件，方便后面一并删除
    FileNameFolder = fileSavePath & "导出图片\"
    '创建名为 FileNameFolder 的文件夹
    MkDir FileNameFolder
    '解压文件
    Dim oShell As Object
    Set oShell = VBA.CreateObject("shell.application")
    oShell.Namespace(FileNameFolder).CopyHere oShell.Namespace(zipFullName).items, 4 + 16   '解压缩文件到指定位置
    Word.Application.ScreenUpdating = True '恢复屏幕刷新
    '7.收拾收拾，把导出的图片移动出来，同时删除第6步建立的文件夹，删除zip文件
    Call moveFile(FileNameFolder & "\word\media\*.*", CStr(fileSavePath))
    Call delete_folder(FileNameFolder)
    Kill fileSavePath & saveAsFileName & ".zip"
    '8.打开图片文件所在目录
    Shell "explorer.exe " & fileSavePath, vbNormalFocus
End Sub
'把指定文件移动到新的文件夹中
'newFilePath无需添加"\",oldfile 可以使用通配符
Public Sub moveFile(oldFile As String, newFilePath As String)
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    oFso.moveFile oldFile, IIf(Right(newFilePath, 1) = "\", Left(newFilePath, Len(newFilePath) - 1), newFilePath)
End Sub
'删除文件夹及下面的所有文件和文件夹
Public Function delete_folder(sPath)
    sPath = IIf(Right(sPath, 1) = "\", Left(sPath, Len(sPath) - 1), sPath)
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Dim oFolder As Object
    If Len(sPath) Then
        '强制删除，参数True表示不管是否只读的文件都删除
        oFso.DeleteFolder sPath, True
    End If
End Function

六、感谢

通过以下作者提供的代码，进行的修改完善。

Word VBA丨一键导出文档所有图片 - 哔哩哔哩 (bilibili.com)

如何用vba删除某个文件夹及其子文件和所有文件？ - VBA - ExcelOffice【微信公众号：水星Excel】