文件名变标题

413191246se

经改动后，又管事了，说明原来的 DIR + 双字典 循环文件夹 代码是没有问题的，只能说单个文档部分是我没做好，也 谢谢 sylun 老师 来救急！ 改动后的代码，楼主看看是否运行正确：

1. Sub DIR_循环遍历文件夹_文件名做标题()
   
2. 
   
3.     On Error Resume Next
   
4. 
   
5.     Dim objShell As Object, objFolder As Object, SearchPath$, DicList As Object, FileList As Object, Key, NowDic$, NowFile$, i&, FileName, FilePath, doc As Document, x&
   
6. 
   
7.     Set objShell = CreateObject("Shell.Application")
   
8.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
   
9. 
   
10.     SearchPath = objFolder.self.Path & ""
    
11. 
    
12.     Set objShell = Nothing
    
13.     Set objFolder = Nothing
    
14. 
    
15.     If MsgBox("请确认！是否处理文件夹 " & SearchPath & " ?", 4 + 16) = vbNo Then Exit Sub
    
16. 
    
17.     Set DicList = CreateObject("Scripting.Dictionary")
    
18.     Set FileList = CreateObject("Scripting.Dictionary")
    
19. 
    
20.     DicList.Add SearchPath, ""
    
21. 
    
22.     i = 0
    
23.     Do While i < DicList.Count
    
24.         Key = DicList.keys
    
25.         NowDic = Dir(Key(i), vbDirectory)
    
26.         Do While NowDic <> ""
    
27.             If (NowDic <> ".") And (NowDic <> "..") Then
    
28.                 If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then DicList.Add Key(i) & NowDic & "", ""
    
29.             End If
    
30.             NowDic = Dir()
    
31.         Loop
    
32.         i = i + 1
    
33.     Loop
    
34. 
    
35.     For Each Key In DicList.keys
    
36.         NowFile = Dir(Key)
    
37.         Do While NowFile <> ""
    
38.             FileList.Add NowFile, Key
    
39.             NowFile = Dir()
    
40.         Loop
    
41.     Next
    
42. 
    
43.     i = 0
    
44.     FileName = FileList.keys
    
45.     FilePath = FileList.Items
    
46.     Do While i < FileList.Count
    
47.         If FilePath(i) & FileName(i) Like "*.doc*" Then
    
48.             Set doc = Documents.Open(FileName:=FilePath(i) & FileName(i), Visible:=False)
    
49.             With doc
    
50.                 .Content.InsertBefore Text:=Left(.Name, Len(.Name) - 5) & vbCr
    
51.                 With .Paragraphs(1).Range
    
52.                     .Style = wdStyleHeading1
    
53.                     With .Font
    
54.                         .Size = 22
    
55.                         .Color = wdColorAutomatic
    
56.                     End With
    
57.                     With .ParagraphFormat
    
58.                         .SpaceBefore = 30
    
59.                         .SpaceAfter = 30
    
60.                         .Alignment = wdAlignParagraphCenter
    
61.                     End With
    
62.                 End With
    
63.                 .Close SaveChanges:=wdSaveChanges
    
64.             End With
    
65.             x = x + 1
    
66.         End If
    
67.         i = i + 1
    
68.     Loop
    
69. 
    
70.     Set DicList = Nothing
    
71.     Set FileList = Nothing
    
72. 
    
73.     MsgBox "文件夹包含 " & i & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
    
74. End Sub

复制代码

T-T-J

非常感谢9楼