VBA批量导入图片到多Word文档并加标题（会飞的鱼）

Posted 2020-11-04 若青若墨

感谢会飞的鱼大牛~

 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