paper8
Sub LayoutForExamPaper8() Dim StartTime As Variant Dim UsedTime As Variant StartTime = VBA.Timer Application.ScreenUpdating = False Dim oneP As Paragraph Dim rng As Range Call ClearParagraphFill Call ConvertNoToText '项目编号转为文本 Call ConvertShape '图形转为inlineShape Call DivideInLineShape '图文分段 Call ReplaceABCDNUM '统一选项字母为半角字母 Call ZeroIndent '0缩进 '全文居左对齐 ActiveDocument.Paragraphs.Format.Alignment = wdAlignParagraphLeft '删除所有空行 ActiveDocument.Content.Find.Execute "^13[ ^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^13", 2 '替换所有空白 ActiveDocument.Content.Find.Execute "^w", , , 0, , , , , , "^s", 2 '全角点号转为半角点号 'ActiveDocument.Content.Find.Execute ".", , , 0, , , , , , ".", 2 '替换手动换行符 ActiveDocument.Content.Find.Execute "^l", , , 0, , , , , , "^13", 2 '插入空白段落 ActiveDocument.Range(0, 0).InsertBefore vbCrLf '删除段首空白 ActiveDocument.Content.Find.Execute "^13@^s@([!^s]@)", , , 1, , , , , , "^13\1", 2 '删除事先插入的空白段落 ActiveDocument.Paragraphs(1).Range = "" '统一题号标点 ActiveDocument.Content.Find.Execute "([0-9]@)[.、]([!^s0-9]@)", , , 1, , , , , , "\1.\2", 2 '删除ABCD及题号尾随空白 ActiveDocument.Content.Find.Execute "([A-D0-9]@)[.、]^s@([!^s]@)", , , 1, , , , , , "\1.\2", 2 'ABCD选项独立为行 ActiveDocument.Content.Find.Execute "[!^13]([B-D].)", , , 1, , , , , , "^13\1", 2 '删除题干和选项段尾空白 ActiveDocument.Content.Find.Execute "(^13[A-D0-9]@.[!^s]@)^s@(^13)", , , 1, , , , , , "\1\2", 2 '选项中间的空白替换为顿号 一个选项多个部分组成的情况 For n = 1 To 5 '最多支持一个选项有5个部分构成 有疑问 括号内多处顿号的问题 ActiveDocument.Content.Find.Execute "(^13[A-D].[! ^s\((]@)^s@([!^s\))]@)", , , 1, , , , , , "\1、\2", 2 Next n Debug.Print " " '删除题干中的空白 For n = 1 To 5 '最多支持一个题干有5处部分构成 ActiveDocument.Content.Find.Execute "(^13[0-9]@.[!^s\((]@)^s@([!^s\))]@)", , , 1, , , , , , "\1\2", 2 Next n '统一括号内为四个空白字符 如 12.该岛屿孤猴集中分布区的自然景观是( ) ActiveDocument.Content.Find.Execute "^13([0-9]@.[!^s]@)[\((]^s@[\))]^13", , , 1, , , , , , "^13\1( )^13", 2 '假回车转硬回车 ActiveDocument.Content.Find.Execute "^13", , , 0, , , , , , "^p", 2 '删除分页符 ActiveDocument.Content.Find.Execute "^m", , , 0, , , , , , "", 2 ActiveDocument.Content.Find.Execute ".", , , 0, , , , , , ".", 2 Call ModifyFont '根据行首行尾字符判断 修改字体格式 Call AddTabStopForOptions '根据选项长度添加制表位 Call InsertPageNo '插入页码 Call PageSetUpB5 '设置纸张 Application.ScreenUpdating = True UsedTime = VBA.Timer - StartTime Debug.Print "UsedTime :" & Format(UsedTime, "#0.0000 Seconds") 'MsgBox "UsedTime :" & Format(UsedTime, "#0.0000 Seconds") End Sub Private Sub ZeroIndent() '清除缩进 With ActiveDocument.Paragraphs.Format .TabStops.ClearAll .CharacterUnitLeftIndent = 0 .CharacterUnitRightIndent = 0 .CharacterUnitFirstLineIndent = 0 '以上三句必须在前面 而以下三句必须在后面才能生效 .FirstLineIndent = CentimetersToPoints(0) .LeftIndent = CentimetersToPoints(0) .RightIndent = CentimetersToPoints(0) .SpaceBefore = 0 .SpaceBeforeAuto = False .SpaceAfter = 0 .SpaceAfterAuto = False .LineUnitBefore = 0 .LineUnitAfter = 0 .MirrorIndents = False End With End Sub Private Sub ClearParagraphFill() With ActiveDocument.Paragraphs.Format With .Shading .Texture = wdTextureNone .ForegroundPatternColor = wdColorAutomatic .BackgroundPatternColor = wdColorAutomatic End With .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone .Borders(wdBorderTop).LineStyle = wdLineStyleNone .Borders(wdBorderBottom).LineStyle = wdLineStyleNone .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone With .Borders .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 .Shadow = False End With End With With Options .DefaultBorderLineStyle = wdLineStyleSingle .DefaultBorderLineWidth = wdLineWidth050pt .DefaultBorderColor = wdColorAutomatic End With End Sub Private Sub ConvertNoToText() Dim oneList As List For Each oneList In ActiveDocument.Lists oneList.ConvertNumbersToText Next End Sub Private Sub ModifyFont() Dim rng As Range For Each oneP In ActiveDocument.Paragraphs n = n + 1 Set rng = oneP.Range If Not rng.Information(wdWithInTable) Then Count = Len(rng.Text) '题干和选项、综合题小题等 字体设置 If rng.MoveStartWhile("(())01234567890123456789ABCDABCD①②③④⑤⑥⑦⑧⑨⑩.、.分", wdForward) >= 1 Then With oneP.Range.Font .Name = "宋体" .Size = 10.5 .ColorIndex = wdBlack .Bold = False .Italic = False End With Else '题型字体设置 If rng.MoveStartWhile("第一二三部分.、.非选择综合题Ⅰ卷Ⅱ卷", wdForward) > 1 Then With oneP.Range.Font .Name = "宋体" .Size = 12 .Bold = True .Italic = False .ColorIndex = wdBlack End With Else '引言字体设置 If rng.MoveEndWhile("1234567890~-据此完成回答下列各题.。(())分结合材料下面小" & Chr(13) & Chr(11), wdBackward) < -2 Or _ rng.MoveStartWhile("材料一二三四五六七、:", wdForward) > 1 Then With oneP.Range.Font .Name = "楷体" .Size = 10.5 .ColorIndex = wdBlack .Bold = False .Italic = False End With Else With oneP.Range.Font .Name = "宋体" .Size = 10.5 .ColorIndex = wdBlack .Bold = False .Italic = False End With End If End If End If End If Next End Sub Private Sub AddTabStopForOptions() '处理选项和制表位 Dim rng As Range Dim ap As Paragraph, bp As Paragraph, cp As Paragraph, dp As Paragraph lenth = ActiveDocument.PageSetup.CharsLine For i = ActiveDocument.Paragraphs.Count To 4 Step -1 Set oneP = ActiveDocument.Paragraphs(i) Set rng = oneP.Range If Not rng.Information(wdWithInTable) Then movestep = rng.MoveStartWhile("D..", 10) If movestep >= 2 Then Set dp = ActiveDocument.Paragraphs(i) Set cp = ActiveDocument.Paragraphs(i - 1) Set bp = ActiveDocument.Paragraphs(i - 2) Set ap = ActiveDocument.Paragraphs(i - 3) If dp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _ cp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _ bp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _ ap.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 Then '一行足够 ap.Range.Text = vbTab & Replace(ap.Range.Text, Chr(13), vbTab) & Replace(bp.Range.Text, Chr(13), vbTab) & Replace(cp.Range.Text, Chr(13), vbTab) & dp.Range.Text bp.Range.Text = "" cp.Range.Text = "" dp.Range.Text = "" AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 4 'Debug.Print "一行" Else If dp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _ cp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _ bp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _ ap.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Then '分四行好看 dp.Range.Text = vbTab & dp.Range.Text cp.Range.Text = vbTab & cp.Range.Text bp.Range.Text = vbTab & bp.Range.Text ap.Range.Text = vbTab & ap.Range.Text AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 1 AddTabStopInRange ActiveDocument.Paragraphs(i - 2).Range, 1 AddTabStopInRange ActiveDocument.Paragraphs(i - 1).Range, 1 AddTabStopInRange ActiveDocument.Paragraphs(i).Range, 1 'Debug.Print "四行" Else '分两行 ap.Range.Text = vbTab & Replace(ap.Range.Text, Chr(13), vbTab) & bp.Range.Text bp.Range.Text = vbTab & Replace(cp.Range.Text, Chr(13), vbTab) & dp.Range.Text cp.Range.Text = "" dp.Range.Text = "" AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 2 AddTabStopInRange ActiveDocument.Paragraphs(i - 2).Range, 2 End If End If End If End If Next i End Sub Private Sub AddTabStopInRange(ByVal rng As Range, ByVal tabStopCount As Integer) Dim pgWidth As Double, pgLeftMargin As Double, opWidth As Integer Dim chrLine As Integer, i As Integer With ActiveDocument.PageSetup pgLeftMargin = .LeftMargin pgWidth = .PageWidth - .LeftMargin - .RightMargin End With opWidth = Int(pgWidth / tabStopCount) '计算选项宽度 chrLine = ActiveDocument.PageSetup.CharsLine '获取每行字符数 rng.ParagraphFormat.TabStops.ClearAll '清除原有制表位 '新增制表位 For i = 1 To tabStopCount rng.ParagraphFormat.TabStops.Add Position:=20 + (i - 1) * opWidth, _ Leader:=wdTabLeaderSpaces, Alignment:=wdAlignTabLeft Next i End Sub Private Sub ConvertShape() '转换图形 Dim shp As Shape Dim inshp As InlineShape ConvertTime = 0 Do While ActiveDocument.Shapes.Count > 0 ConvertTime = ConvertTime + 1 For Each shp In ActiveDocument.Shapes shp.ConvertToInlineShape Next shp If ConvertTime > 20 Then Exit Do Loop End Sub Private Sub DivideInLineShape() Dim p As Paragraph Dim rng As Range For i = ActiveDocument.Paragraphs.Count To 1 Step -1 Set p = ActiveDocument.Paragraphs(i) If p.Range.InlineShapes.Count > 0 Then pic = 0 '不断向后查找段落中inlineshape的位置 并插入回车 lenth = Len(p.Range.Text) Set rng = p.Range hasMove = rng.MoveStartUntil(Chr(47), lenth) m = 0 Do While hasMove > 0 If rng.Characters.First.Previous <> Chr(13) Then rng.InsertBefore vbCrLf End If rng.Start = rng.Start + 1 If rng.Characters.First.Next <> Chr(13) Then rng.InsertBefore vbCrLf End If lenth = Len(rng.Text) hasMove = rng.MoveStartUntil(Chr(47), lenth) m = m + 1 If m = 20 Then Exit Do Loop End If Next i End Sub Private Sub ReplaceABCDNUM() '猜测可能是因为全角符号是两个字符长度 '所以不能在通配查找里面使用字符组[ABCD],因为字符组内每个字符要求单字符长度 Const qjzm As String = "ABCD0123456789. " Const bjzm As String = "ABCD0123456789. " Dim idx As Integer For idx = 1 To 4 ActiveDocument.Content.Find.Execute Mid(qjzm, idx, 1), , , 0, , , , , , Mid(bjzm, idx, 1), 2 Next idx End Sub Private Sub InsertPageNo() Dim rng As Range With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary) Set rng = .Range rng.Font.Size = 10.5 rng.Font.Name = "Times New Roman" ActiveDocument.Fields.Add rng, wdFieldEmpty, "Page" .Range.Fields.Update .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter End With If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close End If If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _ ActivePane.View.Type = wdOutlineView Then ActiveWindow.ActivePane.View.Type = wdPrintView End If 'ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader 'Selection.WholeStory 'Selection.Delete 'With Selection.ParagraphFormat ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader Selection.WholeStory Selection.Delete Selection.ClearFormatting With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range .Delete '删除段落 With .ParagraphFormat .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone .Borders(wdBorderTop).LineStyle = wdLineStyleNone .Borders(wdBorderBottom).LineStyle = wdLineStyleNone With .Borders .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 .Shadow = False End With End With End With With Options .DefaultBorderLineStyle = wdLineStyleSingle .DefaultBorderLineWidth = wdLineWidth075pt .DefaultBorderColor = wdColorAutomatic End With ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument End Sub Private Sub PageSetUpB5() With ActiveDocument.Styles(wdStyleNormal).Font If .NameFarEast = .NameAscii Then .NameAscii = "" End If .NameFarEast = "" End With With ActiveDocument.PageSetup .LineNumbering.Active = False .Orientation = wdOrientPortrait .TopMargin = CentimetersToPoints(1.5) .BottomMargin = CentimetersToPoints(1.5) .LeftMargin = CentimetersToPoints(1.5) .RightMargin = CentimetersToPoints(1.5) .Gutter = CentimetersToPoints(0) .HeaderDistance = CentimetersToPoints(1.5) .FooterDistance = CentimetersToPoints(1.5) .PageWidth = CentimetersToPoints(18.2) .PageHeight = CentimetersToPoints(25.7) .FirstPageTray = wdPrinterDefaultBin .OtherPagesTray = wdPrinterDefaultBin .SectionStart = wdSectionNewPage .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .VerticalAlignment = wdAlignVerticalTop .SuppressEndnotes = False .MirrorMargins = False .TwoPagesOnOne = False .BookFoldPrinting = False .BookFoldRevPrinting = False .BookFoldPrintingSheets = 1 .GutterPos = wdGutterPosLeft .LayoutMode = wdLayoutModeLineGrid End With End Sub