批量提取word文档中的图片到指定文件夹

smiletwo

看到有坛友求助 批量导出word中图片。网上搜了不少资料，最后参考了 http://blog.sina.com.cn/s/blog_3f6643ee0102wixw.html ， 采取的是县复制到excel，再导出的方式实现。（其他几种方式没成功，或者达不到理想效果）。第一次尝试图像提取，敬请各位大师多指导！
具体代码如下： 两段分别处理嵌入图像和悬浮图像

Sub smiletwo()
    Dim Excel_Shape As Shape, MyFile, path
    Dim i%, m%
    Dim Word, Myword As Object
    On Error Resume Next
    path = ThisWorkbook.path & "\"
    MyFile = Dir(path & "*.doc*")
    Set Word = CreateObject("word.application")
    Do While MyFile <> ""
        Set Myword = Word.documents.Open(path & MyFile)
        Word.Visible = flase
        Application.DisplayAlerts = False
        m = 0
        If Myword.Shapes.Count > 0 Then
            For i = 1 To Myword.Shapes.Count
               Myword.Shapes(i).Select
               Word.Selection.Copy
               ActiveSheet.Cells(i, 1).Activate
               ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
               Set Excel_Shape = ActiveSheet.Shapes(1)
               Excel_Shape.Copy
               With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
                  .Paste
                  m = m + 1
                  .Export path & "pic\" & Split(MyFile, ".")(0) & m & ".jpg"
                  .Parent.Delete
               End With
               Excel_Shape.Delete
            Next i
        End If
        If Myword.InlineShapes.Count > 0 Then
            For i = 1 To Myword.InlineShapes.Count
               Myword.InlineShapes(i).Select
               Word.Selection.Copy
               ActiveSheet.Cells(i, 1).Activate
               ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
               Set Excel_Shape = ActiveSheet.Shapes(1)
               Excel_Shape.Copy
               With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
                  .Paste
                  m = m + 1
                  .Export path & "pic\" & Split(MyFile, ".")(0) & m & ".png"
                  .Parent.Delete
               End With
               Excel_Shape.Delete
            Next i
        End If
        Myword.Close
        MyFile = Dir
    Loop
    Set Myword = Nothing
    Word.Quit
    Set Word = Nothing
End Sub

约定的童话

方法大同小异

smiletwo

约定的童话 发表于 2020-12-14 10:32
方法大同小异

小花鹿

直接在WORD中写代码就行子，没必要通过EXCEL

smiletwo

小花鹿 发表于 2020-12-14 13:38
直接在WORD中写代码就行子，没必要通过EXCEL

试了没成功，只有图片文件，但打不开，还请指导一下。最好导出图片的大小能和导入word文档的原始大小相同。

小花鹿

smiletwo 发表于 2020-12-14 13:43
试了没成功，只有图片文件，但打不开，还请指导一下。最好导出图片的大小能和导入word文档的原始大小相同 ...

给你一个思路：另存为网页文件，可以得到图片的原始尺寸                                    

smiletwo

看过，会产生一堆没用的文件，而且难以控制图片文件顺序。

denxh

在WPS中代码不能运行怎行办？

joforn

直接复制media目录下所有文件

smiletwo

joforn 发表于 2021-9-17 17:20
直接复制media目录下所有文件

是先另存网页文件，在复制 media目录下文件吗？