从word中把所有图的图题批量提取到excel中

Sub Macro1()
Dim wd, mypath$, wj$, i&, x%, zf$
Set wd = CreateObject("word.application")
mypath = ThisWorkbook.Path & "\"
wj = Dir(mypath & "文件名.doc")
With wd.Documents.Open(mypath & wj)
    x = .Paragraphs.Count
    For i = 1 To x
        zf = .Paragraphs(i).Range
        If zf Like "*图X-*" Then
              Cells(s + 1, 2) = zf
              s = s + 1
        End If
    Next
    .Close False
End With
wd.Quit
End Sub

使用工具：Excel 2013 VBA

运行环境：Windows10

最近整报告，需要把所有的图，表列个清单。对于大量的图，一个个整理，太费时间了。