优化：保持行距不变保留切换按钮

weiyingde

这是个有关改变字体颜色而达到隐现答案的目的的程序，有两个问题需要优化：
1、切换按钮运行后，删除不见了，如何才能始终保留？
2、运行程序后，行距变大了，由原来的2页变成4页，怎样保持原来版式不变，仍旧是2页。
代码如下：
Private Sub CommandButton1_Click()
With Me.CommandButton1
If .Caption = "隐藏答案" Then
    Call 隐显答案
    .Caption = "公布答案"
    Exit Sub
End If
If .Caption = "公布答案" Then
    Call 隐显答案
    .Caption = "隐藏答案"
    Exit Sub
End If
End With
End Sub
Sub 隐显答案()
    With ActiveDocument.Content
        With .Find
            .Replacement.Font.ColorIndex = 2
            .Replacement.Font.Name = "方正姚体"
            .Execute "[!^13]@", , , 1, , , , , 1, , 2 '匹配拼音
        End With
        With .Find
            .Replacement.Font.ColorIndex = 1
            .Replacement.Font.Name = "华文楷体"
            .Execute "[一-﨩]@", , , 1, , , , , 1, , 2
        End With
    End With
    With ActiveDocument.Content.Find
        .Execute "[　]{1,}", , , 1, , , , , , "^32", 2
        .Execute "^32{1,}([!^13]@)", , , 1, , , , , , "\1", 2 '"[ā-ê]"
        .Execute "^32{1,}([一-﨩]@)", , , 1, , , , , , "\1", 2
        .Execute "([\(（])^32{1,}", , , 1, , , , , , "\1", 2
        .Execute "^32{1,}([\)）])", , , 1, , , , , , "\1", 2
        .Execute "^32{1,}", , , 1, , , , , , "^32", 2
        .Execute "([一-﨩]@)^32{1,}([一-﨩]@)", , , 1, , , , , 2, "\1\2", 2
    End With
    With ActiveDocument.Content.Find
        .Replacement.Font.ColorIndex = IIf(Me.CommandButton1.Caption = "隐藏答案", 8, 2)
        .Execute "\([!^13]@\)", , , 1, , , , , 1, , 2 '匹配拼音
        .Execute "\([一-﨩]@\)", , , 1, , , , , 1, , 2
    End With
    With ActiveDocument.Content.Find
        .Replacement.Font.ColorIndex = 4 '1,黑色；2，蓝色；3，天兰；4，绿色；5，红色；6，红色；7，黄色；8，白色
        .Replacement.Font.Name = "方正姚体"
        .Execute "[\)\(]", , , 1, , , , , 1, , 2
    End With

    Set rg = ActiveDocument.Paragraphs(1).Range
    rg.MoveEnd , -1
    rg.InsertAfter vbCr
    With ActiveDocument.Paragraphs(1)
       istr = .Range.Text
       .Range.Text = IIf(Me.CommandButton1.Caption = "隐藏答案", Left(istr, 8) & "汉字[测试版]", Left(istr, 8) & "汉字[答案版]")
       .Format.Alignment = wdAlignParagraphCenter
       With .Range.Font
            .Bold = True
            .ColorIndex = Choose(Int(Rnd * 10 + 1), wdDarkBlue, wdBlack, wdBlue, wdBrightGreen, wdDarkRed, wdGray25, wdPink, wdTeal, wdViolet, wdGreen)
            .Name = Choose(Int(Rnd * 4 + 1), "腾祥范笑歌楷书简", "华文隶书", "黑体", "华文新魏")
            .Size = 22
       End With
       With .Range
         For i = 9 To .Characters.Count - 1
            .Characters(i).Font.Name = "迷你简黄草"
            .Characters(i).Font.Size = 13
            .Characters(i).Font.ColorIndex = wdViolet
            .Characters(i).Font.Italic = True
            .Characters(i).Font.Line.Style = msoLineSingle
            .Characters(i).Font.Line.ForeColor.RGB = RGB(0, 0, 255)
          Next
      End With
    End With
End Sub

loquat

因为不懂正则简单玩了一下

1. Sub ShowAnswer()
   
2. Application.ScreenUpdating = False
   
3. Dim aDoc As Document
   
4. Dim rng As Range
   
5. Set aDoc = ActiveDocument
   
6. Dim lngStart&, lngEnd&
   
7. Set rng = aDoc.Lists(1).Range
   
8. With rng.Find   '先处理拼音和括号
   
9.     .MatchWildcards = True
   
10.     .Text = "([\(\)a-z\U43169-\U43194 ]{1,})"
    
11.     Do While .Execute
    
12.         Set rng = .Parent
    
13.         rng.Font.Name = "方正姚体"
    
14.         rng.Font.ColorIndex = wdBlue
    
15.         lngStart = rng.Start
    
16.         lngEnd = rng.End
    
17.         aDoc.Range(lngStart, lngStart + 1).Font.ColorIndex = wdGreen
    
18.         aDoc.Range(lngEnd - 1, lngEnd).Font.ColorIndex = wdGreen
    
19.         rng.SetRange lngEnd, aDoc.Lists(1).Range.End   '重置搜索区域
    
20.     Loop
    
21. End With
    
22. Set rng = aDoc.Lists(1).Range
    
23. With rng.Find   '再处理中文
    
24.     .MatchWildcards = True
    
25.     .Text = "([一-﨩]{1,})"
    
26.     Do While .Execute
    
27.         Set rng = .Parent
    
28.         rng.Font.Name = "华文楷体"
    
29.         rng.SetRange rng.End, aDoc.Lists(1).Range.End
    
30.     Loop
    
31. End With
    
32. With aDoc.Range(35, 48)   '处理抬头那几个文字
    
33.     .Font.Name = "迷你简黄草"
    
34.     .Font.Size = 13
    
35.     .Font.ColorIndex = wdViolet
    
36.     .Font.Italic = True
    
37.     .Font.Line.Style = msoLineSingle
    
38.     .Font.Line.ForeColor.RGB = RGB(0, 0, 255)
    
39. End With
    
40. With aDoc.Lists(1).Range
    
41.     .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
    
42.     .ParagraphFormat.DisableLineHeightGrid = True
    
43. End With
    
44. Application.ScreenUpdating = True
    
45. End Sub

复制代码

loquat

更改字体后，你的行高就会变，除非关闭网格对齐

loquat

问题是不是发错区了

weiyingde

你是不是省略了原有功能：
切换按钮不起作用
这两句代码在你的代码中没有了：
  .Range.Text = IIf(Me.CommandButton1.Caption = "隐藏答案", Left(istr, 8) & "汉字[测试版]", Left(istr, 8) & "汉字[答案版]")
这一句是改换标题中的部分文字。
.Replacement.Font.ColorIndex = IIf(Me.CommandButton1.Caption = "隐藏答案", 8, 2)
这一句是隐藏或公布答案。

loquat

weiyingde 发表于 2017-3-23 06:04
你是不是省略了原有功能：
切换按钮不起作用
这两句代码在你的代码中没有了：

因为我只考虑了你要的主体功能
其他这些细节，我没有去刻意还原

loquat

代码并没有放到按钮里
另外，我只写了ShowAnswer，并没有考虑HideAnswer

weiyingde

loquat 发表于 2017-3-22 23:03
更改字体后，你的行高就会变，除非关闭网格对齐

这个程序的大部分功能在其他程序代码中，效果没有意外情况。