VBA批量导入图片到多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 =  To

     Documents.Add DocumentType:=wdNewBlankDocument

     For Each fd In ff.subfolders

         t = Int(fd.Files.Count / )

         For y =  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, "") & Chr()

         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(, "请选择文件目录：", , )

     If Not obmapp Is Nothing Then

         fp = obmapp.Self.Path & ""

     Else

         Exit Sub

     End If

 End Sub

巴特西

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

最新文章

热门文章