批量插入图片并以文件夹及子文件夹命名作分级标题

MCXY

1. Sub 图片批插()
   
2. Rem ************************************************************
   
3. Rem 作    者： 张斌
   
4. Rem 功    能： 将扫描业绩图片文件批量插入word文件中
   
5. Rem 备    注： 需要改进
   
6. Rem 反馈邮箱:gogozb@163.com
   
7. Rem 业务联系QQ：1065886598
   
8. Rem 帖子：http://club.excelhome.net/forum.php?mod=guide&view=my
   
9. Rem ************************************************************
   
10. Rem VBA知识点：
    
11.     Application.ScreenUpdating = False
    
12.     Dim ph$, d As Object, d1 As Object
    
13.     With Application.FileDialog(msoFileDialogFolderPicker)
    
14.         If .Show = -1 Then
    
15.             ph = .SelectedItems(1)
    
16.         Else
    
17.             Exit Sub
    
18.         End If
    
19.     End With
    
20.     ThisDocument.Content.Delete
    
21.     With CreateObject("scripting.filesystemobject")
    
22.         Fn = .GetFileName(ph)
    
23.         With Application.Selection
    
24.             .InsertAfter Fn
    
25.             .Style = ActiveDocument.Styles("标题 1")
    
26.             .EndKey Unit:=wdStory '光标定位至文末
    
27.             .TypeParagraph '插入一个新的空段落
    
28.         End With
    
29.         For Each d In .getfolder(ph).subfolders
    
30.             Fs = .GetFileName(d)
    
31.             With Application.Selection
    
32.                 .InsertAfter Fs
    
33.                 .Style = ActiveDocument.Styles("标题 2")
    
34.                 .EndKey Unit:=wdStory '光标定位至文末
    
35.                 .TypeParagraph '插入一个新的空段落
    
36.             End With
    
37.             For Each d1 In d.Files
    
38.                 If .GetExtensionName(d1) = "JPG" Or .GetExtensionName(d1) = "png" Or .GetExtensionName(d1) = "jpg" Or .GetExtensionName(d1) = "bmp" Then
    
39.                     With Application.Selection
    
40.                         .EndKey Unit:=wdStory '光标定位至文末
    
41.                         .InlineShapes.AddPicture FileName:=d1.Path
    
42.                         .Style = ActiveDocument.Styles("正文")
    
43.                     End With
    
44.                 End If
    
45.             Next d1
    
46.             Selection.TypeParagraph
    
47.         Next d
    
48.     End With
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "插入完毕！", 48, "提示！"
    
51. End Sub

复制代码

考试加油站

不错，思路清晰

MCXY

发过的帖，自己都修改不了