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
