VBA批量导入图片到多Word文档并加标题（会飞的鱼）
感谢会飞的鱼大牛~
1 Public fp$, obmapp As Object 2 Sub kk() 3 文件夹浏览器 4 Application.ScreenUpdating = False 5 Set fso = CreateObject("scripting.filesystemobject") 6 If fp = "" Then Exit Sub 7 Set ff = fso.getfolder(fp) 8 For x = 1 To 17 9 Documents.Add DocumentType:=wdNewBlankDocument 10 For Each fd In ff.subfolders 11 t = Int(fd.Files.Count / 17) 12 For y = 1 To t 13 Selection.InlineShapes.AddPicture FileName:=fd & "\" & x * t - t + y & ".png", LinkToFile:=False, SaveWithDocument:=True 14 Selection.TypeParagraph 15 Selection.TypeText Text:=fd.Name & "_" & Format(x * t - t + y, "00") & Chr(13) 16 Next 17 Next 18 Selection.WholeStory 19 Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 20 21 '替换名称中的+为/ 22 Selection.Find.ClearFormatting 23 Selection.Find.Replacement.ClearFormatting 24 With Selection.Find 25 .Text = "+" 26 .Replacement.Text = "/" 27 .Forward = True 28 .Wrap = wdFindContinue 29 .Format = False 30 .MatchCase = False 31 .MatchWholeWord = False 32 .MatchByte = True 33 .MatchWildcards = False 34 .MatchSoundsLike = False 35 .MatchAllWordForms = False 36 End With 37 Selection.Find.Execute Replace:=wdReplaceAll 38 '上面是录制的宏 39 ActiveDocument.SaveAs2 FileName:=fp & "\" & x & ".docx" 40 ActiveWindow.Close 41 Next 42 Application.ScreenUpdating = True 43 End Sub 44 Sub 文件夹浏览器() 45 Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0) 46 If Not obmapp Is Nothing Then 47 fp = obmapp.Self.Path & "" 48 Else 49 Exit Sub 50 End If 51 End Sub
