排版

wkxxxr

排版能实现，还有一些问题，见“文夹”中“排版汇编”文档，请大神相助

413191246se

楼主，内容不能居左，应该“两端对齐”！

wkxxxr

413191246se 发表于 2016-9-14 12:17
楼主，内容不能居左，应该“两端对齐”！

谢谢，内容就是按正常排版格式，主要是排版之后出现几个问题。

413191246se

楼主：
* 请首先备份好要处理的文档/文件夹。
* 再请删除要处理的文件夹中的“排版汇总”文档。
* 试试我的宏吧（也可以不用我的宏，而参考一下），双击选定要处理的文件夹。

1. Sub test()
   
2.     On Error Resume Next
   
3.     Dim fd As FileDialog, i As Long, doc As Document, p As String, t As Long, s As Long
   
4.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
5.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
   
6.     Set fd = Nothing
   
7.     If MsgBox("是否处理文件夹 " & p & " ?", vbYesNo + vbExclamation, "循环遍历文件夹_通用") = vbNo Then Exit Sub
   
8.     Kill p & "排版汇总.doc"
   
9.     With Application.FileSearch
   
10.         .NewSearch
    
11.         .LookIn = p
    
12.         .SearchSubFolders = True
    
13.         .FileName = "*.doc"
    
14.         If .Execute > 0 Then
    
15.             For i = 1 To .FoundFiles.Count
    
16.                 Set doc = Documents.Open(FileName:=.FoundFiles(i))
    
17. '                doc.Content.Font.Color = wdColorRed '处理单个文档（通用）
    
18. '''
    
19.                 '删除手动换行符和假段落标记
    
20.                 doc.Content.Find.Execute findtext:="^l", replacewith:="^p", Replace:=wdReplaceAll
    
21.                 doc.Content.Find.Execute findtext:="^13", replacewith:="^p", Replace:=wdReplaceAll
    
22. 
    
23.                 '删除段落首尾空格
    
24.                 '全选/居中/两端对齐
    
25.                 '[方法1]
    
26.                 '    SendKeys "^(aej)", True
    
27.                 '[方法2]
    
28.                 '    Selection.WholeStory
    
29.                 '    Application.Run "CenterPara"
    
30.                 '    Application.Run "LeftPara"
    
31.                 '[方法3]
    
32.                 Selection.WholeStory
    
33.                 CommandBars.FindControl(ID:=122).Execute
    
34.                 CommandBars.FindControl(ID:=123).Execute
    
35. 
    
36.                 '删除空行
    
37.                 Dim j As Paragraph
    
38.                 For Each j In ActiveDocument.Paragraphs
    
39.                     If Len(j.Range) = 1 Then j.Range.Delete
    
40.                 Next
    
41. 
    
42.                 '自动编号转文本
    
43.                 doc.Content.ListFormat.ConvertNumbersToText
    
44.                 doc.Content.Find.Execute findtext:="^t", replacewith:="", Replace:=wdReplaceAll
    
45. 
    
46.                 '正文排版
    
47.                 Selection.WholeStory
    
48.                 Selection.ClearFormatting
    
49.                 Selection.ClearFormatting
    
50.                 With Selection.Font
    
51.                     .Size = 12
    
52.                     .Kerning = 0
    
53.                     .DisableCharacterSpaceGrid = True
    
54.                 End With
    
55.                 With Selection.ParagraphFormat
    
56.                     .LineSpacing = LinesToPoints(1.25)
    
57.                     .CharacterUnitFirstLineIndent = 2
    
58.                     .AutoAdjustRightIndent = False
    
59.                     .DisableLineHeightGrid = True
    
60.                 End With
    
61.             
    
62.                 doc.Paragraphs(1).Range.Style = wdStyleHeading2
    
63.                 If doc.Paragraphs(2).Range Like "[!作者：]*" Then doc.Paragraphs(2).Range.InsertBefore Text:="作者："
    
64.                 doc.Paragraphs(2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
    
65.                 doc.Paragraphs(2).Range.InsertAfter Text:=vbCr
    
66. '''
    
67.                 doc.Close savechanges:=wdSaveChanges
    
68.             Next i
    
69. '            MsgBox "处理完毕！共处理 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹_通用"
    
70.         Else
    
71.             MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_通用"
    
72.         End If
    
73.     End With
    
74. 
    
75. '循环遍历文件夹_批量合并
    
76.     t = 0
    
77.     s = 1
    
78.     Documents.Add
    
79.     With Application.FileSearch
    
80.         .NewSearch
    
81.         .LookIn = p
    
82.         .SearchSubFolders = True
    
83.         If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
    
84.         If .Execute > 0 Then
    
85.             For i = 1 To .FoundFiles.Count
    
86.                 If t = 0 Then Set doc = Documents.Open(FileName:=.FoundFiles(i)) Else Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936)
    
87.                 doc.Content.Copy
    
88.                 doc.Close
    
89.                 Selection.EndKey Unit:=wdStory
    
90.                 Selection.Paste
    
91.                 ActiveDocument.Characters(1).Copy
    
92.                 If s = 1 Then Selection.InsertBreak Type:=wdPageBreak
    
93.             Next i
    
94.             If s = 1 Then Selection.TypeBackspace: Selection.TypeBackspace Else Selection.TypeBackspace
    
95.             MsgBox "文档已经保存！退出即可！（保存路径：" & p & "）" & "共合并 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹_批量合并"
    
96.         Else
    
97.             MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_批量合并"
    
98.         End If
    
99.     End With
    
100.     ActiveDocument.SaveAs FileName:=p & "\排版汇总（最新）" & ".doc"
     
101.     Selection.HomeKey Unit:=wdStory
     
102.    
     
103. End Sub

复制代码

wkxxxr

413191246se 发表于 2016-9-14 13:34
楼主：
* 请首先备份好要处理的文档/文件夹。
* 再请删除要处理的文件夹中的“排版汇总”文档。

辛苦了，中午这么快写得简洁。问题：1、第二段不一定有“作者”字眼，如果正文也有这二字呢，能否按段落来排；2、通过打开文件夹来选定要排版汇总文档，不一定全部文档。

413191246se

楼主好！代码都是拼凑的；第二段如果是一个大段而不是人名，当然会出错；有选择地选定文档，且应用窗体，我不太会；另外，我觉得你的问题也不必应用窗体，也许你认为应用窗体好。

wkxxxr

413191246se 发表于 2016-9-14 18:02
楼主好！代码都是拼凑的；第二段如果是一个大段而不是人名，当然会出错；有选择地选定文档，且应用窗体，我 ...

多谢了，能否根据我发的文档代码进行修改，主要问题是文档批量排版后会打开每个文档，怎么直接保存或另存后退出不需打开窗口，试了几回，提示重启office回复文档出错。

413191246se

楼主，抛弃你的代码吧！用我的代码，按我 4 楼的回答去做，就 OK 了！（请把代码放到 Normal.dot 中，不要放在 This Document 中。）