批量导出word内插图片代码，亲测可用

zzpsx

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



不足之处是，导出的图片命名是如下的，要是命名为图1，图2……这样就更好了。导出的图片如果能再清楚一点，更好。

smiletwo

批量提取word文件图片，根据word文件名顺序编号图片名称

zzpsx

smiletwo 发表于 2023-2-20 09:32
批量提取word文件图片，根据word文件名顺序编号图片名称

大神，这个代码可否不发截图，发文本，谢谢了。

smiletwo

不好意思，重装了系统，找不到了。

zzpsx

来顶一下

常扬帆

代码它过虑掉了重复图片，下面附件中，共10道题，10张图片，只导出了9张，因为第7题的图片重复了第2的图片，被过虑掉了，如果带序号的话，就应该知道哪些图片是重复的了。

Excel2119

经常来excelhome来看看，定能发现经典之作，感谢分享哈。

dublove

导出的图片多时imge.bin，请问如何解？

baoxuehero

docx另存为压缩文件，解压缩后就有图片呀