word VBA保存文档中所有图片

Sub saveAllPic()
    
    
    On Error Resume Next
    
    Const adTypeBinary = 1
    '默认文本数据
    Const adTypeText = 2
    '指定保存到文件时不覆盖，只新建
    Const adSaveCreateNotExist = 1
    '指定保存到文件时覆盖原文件，没有则新建
    Const adSaveCreateOverWrite = 2
    
    Dim oStream As Object
    Dim arr() As Byte
    Set oStream = VBA.CreateObject("adodb.stream")
    i = 1
    Dim oDoc As Document
    Set oDoc = Word.ActiveDocument
    Dim oSP As Shape
    Dim sPath As String
    If oDoc.Saved Then   '如果文档已保存,就把图片存放到文档相同路径.
        sPath = oDoc.Path & "\" & oDoc.Name & "_shape_"
    Else
        MsgBox ("文档未保存,无法将图片保存到文档所在文件夹.请先保存文档!")
        Exit Sub
    End If
    
    
    
    Dim oInLineSp As InlineShape
    With oDoc
        For Each oSP In .Shapes
            oSP.Select
            arr = Word.Selection.EnhMetaFileBits
            With oStream
                .Open
                .Type = adTypeBinary
                .Write arr
                .SaveToFile sPath & i & ".emf", adSaveCreateOverWrite
                .Close
            End With
            i = i + 1
        Next
        For Each oInLineSp In .InlineShapes
            arr = oInLineSp.Range.EnhMetaFileBits
            With oStream
                .Open
                .Type = adTypeBinary
                .Write arr
                .SaveToFile sPath & i & ".emf", adSaveCreateOverWrite
                .Close
            End With
            i = i + 1
        Next
    End With
    Shell "explorer.exe " & oDoc.Path, vbMaximizedFocus
    
End Sub