学习笔记411

Sub ClearBlankBeforeParagraph()
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    Application.ScreenUpdating = False
    Dim oneP As Paragraph
    Dim rng As Range
    Call ConvertShape
    Call DivideInLineShape
    '删除所有空行
    ActiveDocument.Content.Find.Execute "^13[ 　^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^p", 2
    '清除缩进
    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
    
    ActiveDocument.Content.Find.Execute "^l", , , 0, , , , , , "^13", 2 '软回车转硬回车
    
    ActiveDocument.Range(0, 0).InsertBefore vbCrLf
    ActiveDocument.Content.Find.Execute "[^13^11]@[ 　^s^32^t]@([! ^t　^s^32]@)", , , 1, , , , , , "^13\1", 2   '删除段首空白和替换回车
    ActiveDocument.Paragraphs(1).Range = ""
    ActiveDocument.Content.Find.Execute "([ABCD])[.、．][ ^s^32　^t?" & Chr(63) & ChrW(160) & "]@([! ^t^s^32]@)", , , 1, , , , , , "\1．\2", 2 '删除字母和选项之间的空白
    ActiveDocument.Content.Find.Execute "[!^13]([BCD]．)", , , 1, , , , , , "^13\1", 2  'ABCD选项独立一行
    ActiveDocument.Content.Find.Execute "(^13[ABCD]．[!^13]@)[ ^s^32　^t? " & Chr(63) & Chr(160) & "]@(^13)", , , 1, , , , , , "\1\2", 2  '删除选项后面的空白
    ActiveDocument.Content.Find.Execute "(^13[ABCD]．[! ^s^32　^t?" & Chr(63) & Chr(160) & "]@)[ ^s^32　^t?" & Chr(63) & "]@([! ^s^32　^t?" & Chr(63) & Chr(160) & "]@^13)", , , 1, , , , , , "\1、\2", 2    '选项中间多个答案部分之间的空白
    ActiveDocument.Content.Find.Execute "^13", , , 0, , , , , , "^p", 2 '假回车转硬回车
    ActiveDocument.Content.Find.Execute "^m", , , 0, , , , , , "", 2 '分页符
    Call ModifyFont
    Call AddTabStopForOptions
    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 ModifyFont()
    For Each oneP In ActiveDocument.Paragraphs
        n = n + 1
        Set rng = oneP.Range
        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
    Next
End Sub
Private Sub AddTabStopForOptions()
    '处理选项和制表位
    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
        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
    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
            '不断向后查找段落中inlineshape的位置 并插入回车
            lenth = Len(p.Range.Text)
            Set rng = p.Range
            Debug.Print rng.Text
            hasMove = rng.MoveStartUntil(Chr(47), lenth)
            m = 0
            Do While hasMove > 0
                rng.Start = rng.Start + 1
                Debug.Print ">>>>>>"; Asc(rng.Characters.First.Next)
                If rng.Characters.First.Next <> Chr(13) Then rng.InsertBefore Chr(13)
                m = m + 1
                lenth = Len(rng.Text)
                hasMove = rng.MoveStartUntil(Chr(47), lenth)
                If m = 20 Then Exit Do
            Loop
        End If
        
    Next i
End Sub