Insert every picture of subfolder and type subfolder name as a heading1 in blank pages

43 views Asked by At

Under this path {c:\testbatpic} ,there are many folders,such as name is abc, def,ghi ... n, under abc subfolder ,there are a lot of images, such as , 1.jpg,2.jpg ... n.jpg or png files. many subfolder included many images. how to type subfolder name with a "heading1"style,in blank pages,and insert every picture of subfolder?
Here is some code,but how modify these code to meet my idea?

Sub loopAllSubFolderSelectStartDirectory()
 Dim FSOLibrary As FileSystemObject
 Dim FSOFolder As Object
 Dim folderName As String

 folderName = "C:\testbatpic"

 Set FSOLibrary = New FileSystemObject

 LoopAllSubFolders FSOLibrary.getfolder(folderName)

End Sub

Sub LoopAllSubFolders(FSOFolder As Object)

 Dim FSOSubFolder As Object
 Dim FSOFile As Object

 For Each FSOSubFolder In FSOFolder.subfolders
     LoopAllSubFolders FSOSubFolder
     With Selection
     .Range.Text = Chr(13) & FSOSubFolder.name
 End With
Next

For Each FSOFile In FSOFolder.Files
 ActiveDocument.InlineShapes.AddPicture (FSOFile.path)
Next

End Sub
1

There are 1 answers

1
He Gang On
    Sub InsertMulti_pic_with_subfoldername()
 'To traversal every subfolder under path,then print out subfolder name on 
 'word,after insert all picture  2022.09.21 by Dagang
    Dim FSOLibrary As Object                                          
    Dim FSOFolder As Object
    Dim folderName As String
    folderName = "D:\desktop folder\pic\"             
    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    LoopAllSubFolders FSOLibrary.GetFolder(folderName)               
    ActiveDocument.Paragraphs(1).Range.Delete                        
End Sub
Sub LoopAllSubFolders(FSOFolder As Object)
    Dim FSOSubFolder As Object
    Dim FSOFile As Object
    Dim rng As Word.Range
    Set rng = Selection.Range
  For Each FSOSubFolder In FSOFolder.subfolders                       
      With Selection                                                   
           rng.Start = ActiveDocument.Content.End                     
           .InsertBreak Type:=wdPageBreak                             
            rng.Start = ActiveDocument.Content.End                     
           .InsertBreak Type:=wdPageBreak
           .EndKey unit:=wdStory
           rng.Text = FSOSubFolder.name
              Set rng = rng.Paragraphs(1).Range                        
                  rng.style = Word.WdBuiltinStyle.wdStyleHeading1       
                  rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
     End With
     LoopAllSubFolders FSOSubFolder                                      
  Next

  For Each FSOFile In FSOFolder.Files                                     
      Selection.InlineShapes.AddPicture (FSOFile.path)                    
  Next
End Sub