20190411wdVBA_排版

Sub LayoutForExamPaper()
    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 ReplaceABCD '统一选项字母为半角字母
    Call ZeroIndent '0缩进
    '删除所有空行
    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 "^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 = ""
    '删除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
    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("(（）)0123456789０１２３４５６７８９ＡＢＣＤABCD①②③④⑤⑥⑦⑧⑨⑩.、．分", 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 Then 'dasdasd
                        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 ReplaceABCD()
    Const qjzm As String = "ＡＢＣＤ"
    Const bjzm As String = "ABCD"
    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 = 11
        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
    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