批量插入子文件夹内的所有图片问题

大罡

假设路径C:\testbatpic 下有 文件夹 abc，def，.....n个文件夹，abc文件夹下有图片 1.jpg，2，jpg.....n.jpg.
如何实现

1.在光标点批量插入这些图片，
2，在插入某个文件夹的所有图片之前，打出文件夹名称。即，打印文件夹名abc，然后在下一行执行插入操作，当最后abc文件夹最后一个图片插入完，后，打出下一个文件夹名称，然后执行插入。。。。。直到第 n个文件插入结束。
不清楚该怎么修改如下代码，来满足以上 需求。谢谢大神帮助。

Sub loopAllSubFolderSelectStartDirectory()

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String

folderName = "C:\testbatpic"


Set FSOLibrary = CreateObject("Scripting.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

Next

For Each FSOFile In FSOFolder.Files


Selection.InlineShapes.AddPicture (FSOFile.path)
Next

End Sub

xiangbaoan

1. Sub test1()
   
2.   Dim sPath As String, oFolder As Object, oFile As Object, bFilesExists As Boolean
   
3.   Dim Cel As Range, Shp As Shape, iRow As Integer, pCol As Integer
   
4.   sPath = "c:\testbatpic"
   
5.   If Dir(sPath, vbDirectory) = "" Then MsgBox "Not exists " & sPath: Exit Sub
   
6.   ActiveSheet.Pictures.Delete
   
7.   Application.ScreenUpdating = False
   
8.   With ActiveCell
   
9.     iRow = .Row - 1
   
10.     pCol = .Column
    
11.   End With
    
12.   For Each oFolder In CreateObject("Scripting.FileSystemObject").GetFolder(sPath).SubFolders
    
13.     bFilesExists = False
    
14.     For Each oFile In oFolder.Files
    
15.       If LCase(Right(oFile.Name, 4)) = ".jpg" Then
    
16.         If Not bFilesExists Then
    
17.           iRow = iRow + 1
    
18.           Cells(iRow, pCol) = oFolder.Name 'oFolder.Path
    
19.           bFilesExists = True
    
20.         End If
    
21.         iRow = iRow + 1
    
22.         Set Cel = Cells(iRow, pCol)
    
23.         Cel.Value = oFile.Name             'oFile.Path
    
24.         Set Shp = ActiveSheet.Shapes.AddPicture(oFile.Path, msoFalse, msoCTrue, Cel.Left, Cel.Top, Cel.Width, Cel.Height)
    
25.         Shp.Placement = xlMoveAndSize
    
26.       End If
    
27.     Next
    
28.   Next
    
29.   Set Cel = Nothing
    
30.   Set Shp = Nothing
    
31.   Application.ScreenUpdating = True
    
32. End Sub

复制代码

大罡

xiangbaoan 发表于 2022-9-13 09:33

不好意思忘记说了，是在word下面，实现。但是上面代码似乎 连文件名也打印出来了，不需要打印文件名，只需要 打印 subfolder的名称

xiangbaoan

大罡 发表于 2022-9-13 10:56
不好意思忘记说了，是在word下面，实现。但是上面代码似乎 连文件名也打印出来了，不需要打印文件名，只 ...

呵呵呵，抢答出问题了算是顶一下吧。
word不会，23行与文件名有关。

3190496160

上传附件来看看吧，没有附件，说再多别人也没法理解你的意思的

大罡

简单粗暴有效地解决了问题。

1. Sub InsertMulti_pic_with_subfoldername()
   
2. '程序遍历定义的文件夹后，在空白word文档批量输出图片，并输出子文件夹名称，并将定义称标题样式 2022.09.21 by Dagang
   
3.     Dim FSOLibrary As Object                                          
   
4.     Dim FSOFolder As Object
   
5.     Dim folderName As String
   
6.     folderName = "D:\desktop folder\pic"             '定义一个要处理图片的路径
   
7.     Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
   
8.     LoopAllSubFolders FSOLibrary.GetFolder(folderName)                '调用子程序并传参
   
9.     ActiveDocument.Paragraphs(1).Range.Delete                         '删除首行分页符
   
10. End Sub
    
11. Sub LoopAllSubFolders(FSOFolder As Object)
    
12.     Dim FSOSubFolder As Object
    
13.     Dim FSOFile As Object
    
14.     Dim rng As Word.Range
    
15.     Set rng = Selection.Range
    
16.   For Each FSOSubFolder In FSOFolder.subfolders                        '遍历预定义下的子目录
    
17.       With Selection                                                   '输出字符串格式化
    
18.            rng.Start = ActiveDocument.Content.End                      '定位到文档末尾
    
19.            .InsertBreak Type:=wdPageBreak                              '插入一个分节符
    
20.             rng.Start = ActiveDocument.Content.End                     '定位到文档末尾
    
21.            .InsertBreak Type:=wdPageBreak
    
22.            .EndKey unit:=wdStory
    
23.            rng.Text = FSOSubFolder.name
    
24.               Set rng = rng.Paragraphs(1).Range                         '定义的预修饰的范围
    
25.                   rng.style = Word.WdBuiltinStyle.wdStyleHeading1       ' 将子文件夹名渲染成标题1样式
    
26.                   rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
    
27.      End With
    
28.      LoopAllSubFolders FSOSubFolder                                      '定义的预修饰的范围
    
29.   Next
    
30. 
    
31.   For Each FSOFile In FSOFolder.Files                                     '遍历所有文件
    
32.       Selection.InlineShapes.AddPicture (FSOFile.path)                     '批量插入图片
    
33.   Next
    
34. End Sub

复制代码

xzcdcak

不错。学习下。太牛了。