以下代码为何不能批量执行修改选定文件夹内的页边距

qinhuan66

1. 以下代码为何不能批量执行修改选定文件夹内所有WORD文档的页边距

复制代码

测试.rar (53.78 KB, 下载次数: 4)

2019-4-28 16:11 上传

点击文件名下载附件

1. Sub 修改文件()
   
2. Dim fol As Object, doc As Document, pa$, f$
   
3.     Dim h As HeaderFooter, se As Section, s$, T$
   
4.     Application.ScreenUpdating = False
   
5.     Set fol = CreateObject("Shell.Application").BrowseForFolder(0, "选取目标文件夹", 0)
   
6.     If Not fol Is Nothing Then pa$ = fol.Items.Item.Path Else MsgBox "请选目标文件夹": Exit Sub
   
7.   '-----------------------------------------------------------------------------------------------
   
8.     Call 页边距
   
9.   '-----------------------------------------------------------------------------------------------
   
10. End Sub
    
11. 
    
12. Sub 页边距()
    
13. '修改页边距
    
14. Dim s As Section
    
15.     For Each s In ActiveDocument.Sections
    
16.         With s.PageSetup
    
17.             .TopMargin = CentimetersToPoints(2.7)
    
18.             .BottomMargin = CentimetersToPoints(3.5)
    
19.         End With
    
20.     Next
    
21. End Sub

复制代码

413191246se

楼主，你的代码并未打开文档，故无法设置页边距。请试试以下代码（请将重要资料打包备份好试验）：

1. Sub test批量设置页边距()
   
2. 'code by 捷克人
   
3.     On Error Resume Next
   
4.     Dim fd As FileDialog, p$, doc As Document, n&
   
5.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else End
   
7.     Set fd = Nothing
   
8.     If MsgBox("是否处理文件夹 " & p & " ?", 4 + 48) = vbNo Then End
   
9.     Dim FileNameWithPath As Variant, ListOfFilenamesWithParh As New Collection
   
10.     Call FileSearchByHavrda(ListOfFilenamesWithParh, p, "*.doc", True)
    
11.     For Each FileNameWithPath In ListOfFilenamesWithParh
    
12.         Set doc = Documents.Open(FileName:=FileNameWithPath, Visible:=False)
    
13.         With doc
    
14.             With .PageSetup
    
15.                 .TopMargin = CentimetersToPoints(2.7)
    
16.                 .BottomMargin = CentimetersToPoints(3.5)
    
17.             End With
    
18.             .Close savechanges:=wdSaveChanges
    
19.         End With
    
20.         n = n + 1
    
21.     Next FileNameWithPath
    
22.     If ListOfFilenamesWithParh.Count = 0 Then MsgBox "File not found!"
    
23.     MsgBox "处理完毕！共处理 " & n & " 个文档！", 0 + 48
    
24. End Sub
    
25. Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
    
26.     Dim DirFile As String, CollectionItem As Variant, SubDirCollection As New Collection
    
27.     pPath = Trim(pPath)
    
28.     If Right(pPath, 1) <> "" Then pPath = pPath & ""
    
29.     DirFile = Dir(pPath & pMask)
    
30.     Do While DirFile <> ""
    
31.         pFoundFiles.Add pPath & DirFile
    
32.         DirFile = Dir
    
33.     Loop
    
34.     If Not pIncludeSubdirectories Then Exit Sub
    
35.     DirFile = Dir(pPath & "*", vbDirectory)
    
36.     Do While DirFile <> ""
    
37.         If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
    
38.         DirFile = Dir
    
39.     Loop
    
40.     For Each CollectionItem In SubDirCollection
    
41.          Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories)
    
42.     Next
    
43. End Sub

复制代码

413191246se

楼主，如果每节均设置为相同的页边距，其实可以设置整个文档为某个页边距，何必单独设置“节”呢！？这一点我也糊涂了。以下代码仅供参考（页边距也是录制宏，但精简了，分纵向、横向）：

1. Sub PaperSetup()
   
2.     Dim s As Section
   
3.     For Each s In ActiveDocument.Sections
   
4.         With s.PageSetup
   
5.             If .Orientation = wdOrientPortrait Then
   
6.                 .TopMargin = CentimetersToPoints(2.54)
   
7.                 .BottomMargin = CentimetersToPoints(2.54)
   
8.                 .LeftMargin = CentimetersToPoints(3.17)
   
9.                 .RightMargin = CentimetersToPoints(3.17)
   
10.                 .PageWidth = CentimetersToPoints(21)
    
11.                 .PageHeight = CentimetersToPoints(29.7)
    
12.             Else
    
13.                 .TopMargin = CentimetersToPoints(2.5)
    
14.                 .BottomMargin = CentimetersToPoints(2.5)
    
15.                 .LeftMargin = CentimetersToPoints(2.54)
    
16.                 .RightMargin = CentimetersToPoints(2.54)
    
17.                 .PageWidth = CentimetersToPoints(29.7)
    
18.                 .PageHeight = CentimetersToPoints(21)
    
19.             End If
    
20.             .HeaderDistance = CentimetersToPoints(1.5)
    
21.             .FooterDistance = CentimetersToPoints(1.75)
    
22.         End With
    
23.     Next
    
24. End Sub

复制代码

413191246se

楼主，请注意：必须双击文件夹，直到打开你要的文件夹后，按“确定”。另外，请做好文档备份。