可以自动遍历文件夹批量删除文档水印和页眉页脚的VBA代码

focuson1

1. Dim arrFiles()
   
2. Dim cntFiles%
   
3. Public Sub ListAllFiles()
   
4.       Dim myDialog As FileDialog, oDoc As Document, oSec As Section
   
5.       Dim oFile As Variant, myRange As Range
   
6.       On Error Resume Next
   
7.         Dim strPath$
   
8.         Dim i%
   
9.         Dim fso As New FileSystemObject, fd As Folder
   
10. 
    
11.         strPath = ActiveDocument.Path & Application.PathSeparator   '········
    
12.         ReDim arrFiles(1 To 1000)
    
13.         cntFiles = 0
    
14.         Set fd = fso.GetFolder(strPath)
    
15.         SearchFiles fd
    
16.         ReDim Preserve arrFiles(1 To cntFiles)
    
17.         For i = 1 To cntFiles
    
18.             Set oDoc = Word.Documents.Open(FileName:=arrFiles(i), Visible:=False)
    
19.             For Each oSec In oDoc.Sections    '文档的节中循环
    
20.                 Set myRange = oSec.Headers(wdHeaderFooterPrimary).Range
    
21.                 myRange.Delete    '删除页眉中的内容
    
22.                 myRange.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone    '段落下边框线
    
23.                 Set myRange = oSec.Footers(wdHeaderFooterPrimary).Range
    
24.                 myRange.Delete    '删除页脚中的内容
    
25.             Next
    
26.             oDoc.Close True
    
27.         Next i
    
28. End Sub
    
29. 
    
30. Sub SearchFiles(ByVal fd As Folder)
    
31.     Dim fl As File
    
32.     Dim sfd As Folder
    
33.     For Each fl In fd.Files
    
34.       cntFiles = cntFiles + 1
    
35.       If cntFiles > UBound(arrFiles) Then ReDim Preserve arrFiles(1 To cntFiles + 1000)
    
36.      
    
37.       m = Split(fl.Name, ".")(1)
    
38.       If m = "doc" Or m = "docx" Then
    
39.         arrFiles(cntFiles) = fl.Path
    
40.       End If
    
41. 
    
42.       arrFiles(cntFiles) = fl.Path
    
43.     Next fl
    
44.     If fd.SubFolders.Count = 0 Then Exit Sub
    
45.     For Each sfd In fd.SubFolders
    
46.       SearchFiles sfd
    
47.     Next
    
48. End Sub

复制代码

vbee

谢谢分享，EH有你更精彩