如何通过VBA对下列各小题进行排版

tangqingfu

请教：
如何通过VBA将附件中的排版前的内容批量替换成排版后的内容？
能否通过一段宏代码进行灵活设定每行为几小题（如3小题或4小题等）,各小题制表位的大小能随页面大小及题数的变化而变化？如果不行，能否帮忙写其中一种（如替换“词汇”部分,将每行各小题设为三小题）的VBA代码?

[ 本帖最后由 tangqingfu 于 2009-5-9 21:45 编辑 ]

sylun

可试试如下代码，其中每行小题数需指定，且对段落只拆分不合并。
Sub MultiTopic()
Dim myRange As Range, tabcount As Byte, tabwidth As Single, i As Byte
Application.ScreenUpdating = False
With Selection
    Set myRange = IIf(.Type = wdSelectionIP, ActiveDocument.Content, .Range)
    tabcount = Val(InputBox("请输入每个段落的小题数", , "4"))
    If tabcount < 1 Then Exit Sub
    tabwidth = myRange.PageSetup.TextColumns.Width / tabcount  '计算每个自定义制表位的间距
    For i = 1 To tabcount  '依次设置每个自定义制表位
        myRange.ParagraphFormat.TabStops.Add i * tabwidth
    Next
    myRange.Select
    With .Find
        .ClearFormatting
        .Text = "^95{3,}"  '查找内容（三个以上连续的下划线符号）
        .MatchWildcards = True
        i = 0  '计数复位
        Do While .Execute  '对匹配项目循环处理
            With .Parent
                If .End > myRange.End Then Exit Do  '匹配内容如超出指定范围则退出循环
                .Text = vbTab  '将匹配内容替换为制表符
                .Font.Underline = wdUnderlineSingle  '匹配内容应用下划线格式
                i = i + 1
                If i Mod tabcount = 0 And .End < .Paragraphs(1).Range.End - 1 Then .InsertAfter Chr(13)  '按指定制表符数拆分段落
                .Collapse wdCollapseEnd  '向后折叠匹配内容
            End With
        Loop
    End With
End With
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 sylun 于 2009-5-10 17:57 编辑 ]

szh9388

值得学习，我也想知道

tangqingfu

谢谢sylun兄的帮忙!总体效果很不错!能否加入注释学习一下?
能否在代码中加入这样的情况:(我想在应该是在运行sylun兄代码前进行处理)
如果每行有段落标记则将其删除,如果小题序号前有半角空格或全角空格,则将其删除。详见"排版前"第二处的"词汇"和"词组"部分.
^95代表什么？

[ 本帖最后由 tangqingfu 于 2009-5-10 07:59 编辑 ]

sylun

已在2楼添加了一些说明文字，查找内容也稍作了修改。其实以前也做过类似处理。
楼主新提出的两个要求未作一并处理，因感觉有不确定性，还是由楼主按实际情况酌情处理好点。比如查找内容可试改为“[^32^95]{3,}"  ，只是与“吃药”这样的下划线有冲突（感觉此种情形用分号分隔比空格要好些）。

tangqingfu

谢谢sylun兄，收藏学习，有问题再请教！

szh9388

实用，谢楼主了

x332553761

高手，学习中~！~！~！~！~！真的见到的WORD 排版高手