批量导入图片到多Word文档并加标题

Public fp$, obmapp As Object
Sub kk()
文件夹浏览器
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
If fp = "" Then Exit Sub
Set ff = fso.getfolder(fp)
For x = 1 To 17
    Documents.Add DocumentType:=wdNewBlankDocument
    For Each fd In ff.subfolders
        t = Int(fd.Files.Count / 17)
        For y = 1 To t
            Selection.InlineShapes.AddPicture FileName:=fd & "\" & x * t - t + y & ".png", LinkToFile:=False, SaveWithDocument:=True
            Selection.TypeParagraph
            Selection.TypeText Text:=fd.Name & "_" & Format(x * t - t + y, "00") & Chr(13)
        Next
    Next
    Selection.WholeStory
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

    '替换名称中的+为/
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "+"
        .Replacement.Text = "/"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    '上面是录制的宏
    ActiveDocument.SaveAs2 FileName:=fp & "\" & x & ".docx"
    ActiveWindow.Close
Next
Application.ScreenUpdating = True
End Sub
Sub 文件夹浏览器()
    Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
    If Not obmapp Is Nothing Then
        fp = obmapp.Self.Path & ""
    Else
        Exit Sub
    End If
End Sub