VBA如何遍历某一个word中的全部图片，把它们一一保存在指定的文件夹中？

smiletwo

zzpsx 发表于 2023-1-26 09:32
请教高手，这个怎么解决？

smiletwo

zzpsx 发表于 2023-1-26 09:32
请教高手，这个怎么解决？

复制后 【pic】后面有斜杠 \
据说是bug，EH输入代码<>   时 显示不出来。

smiletwo

zzpsx

smiletwo 发表于 2023-1-27 17:48

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) & Format(m, "000") & "A.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) & Format(m, "000") & "A.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

zzpsx

来顶一下，谢谢。

smiletwo

zzpsx 发表于 2023-1-27 17:57
Sub smiletwo()
    Dim Excel_Shape As Shape, MyFile, path
    Dim i%, m%

新建excel文件，复制44楼代码 单步运行情况如下：
请查看相关路径和你的文件路径是否一致。