如何通过VBA自动生成题号+下划线的形式?

tangqingfu

请教如何用代码快速生成多个题号+下划线的形式,如:
1._____2._____3._____4._____5._____6._____7._____8._____9._____10._____
11.____12.____13.____14.____15.____16.____17.____18.____19.____20._____
21.____22.____23.____24.____25.____26.____27.____28.____29.____30._____
最好能做到:
根据文档页面的宽度及其栏宽的大小,均分一行各小题所占的大小?(自动生成题号+下划线的格式)
如果想要设置一行为10个小题,运行代码,就会弹出一个提示框,询问用户"一行要输入几小题",用户在文本框中输入如"10"这样的数据,就能将一行的大小10等分,如果用户在文本框中输入如"5"这样的数据,就能将一行的大小5等分,然后再弹出一个提示框,询问用户"要输入几行"(默认值为1),如果用户在文本框中输入"3",则能在光标及其后面两行(段)进行操作,且各小题能自动编号。

[ 本帖最后由 tangqingfu 于 2009-6-2 23:36 编辑 ]

kqbt

做个标记
文档中用的不是下划线？似乎是文字边框？

szh9388

我也做个记号，等待高手解决，以便他日之用

wjhere

'利用表格的“根据窗口调整表格”功能实现根据页面来插入题号
请大家改进。如果不利用表格能否根据窗口调整长短？

kqbt

从wjhere兄的代码中学到了一些新东西，谢谢！

tangqingfu

谢谢wjhere兄的帮助!收藏学习!

tangqingfu

请教wjhere兄:
将您的代码放到normal下的模块中,发现不能使用,提示为"变量未定义",位置是    "b = myTable.Range.Cells(1).Width - 3"中的"b="
如果将normal下的模块中的其他所有代码删除后再运行您的代码,又可以使用.请教该如何修改?

[ 本帖最后由 tangqingfu 于 2009-6-4 16:17 编辑 ]

wjhere

qingfu兄跟我就不必客气了。
是你原来的代码中模块声明了
Option Explicit
即强制变量定义，在模块级别中使用，强制显式声明模块中的所有变量。可参考帮助。如果变量没有定义就会出错，在过程中加入一句：
dim b as byte
即可。
Sub 题号()
'
'利用表格的“根据窗口调整表格”功能实现根据页面来插入题号
Dim myTable As Table
Dim myCell As Cell
Dim k As Integer
Dim t, b As Byte
Dim R, C As Byte
Application.ScreenUpdating = False
R = InputBox("要输入几行？", "请输入行数", 1)
C = InputBox("一行要输入几小题？", "请输入每行小题数", 10)
Set myTable = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=R, NumColumns:= _
        C, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitWindow)
    With myTable
        If .Style <> "网格型" Then
            .Style = "网格型"
        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = True
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = True
         
    b = myTable.Range.Cells(1).Width - 3
    For Each myCell In myTable.Range.Cells
    k = k + 1
   
    myCell.Range.Text = k & "." & Space(b)
    myCell.Range.Words(2).Font.Underline = wdUnderlineSingle
    Next
    End With
   
    '删除边框
    Dim br As Border
    For Each br In myTable.Borders
    br.LineStyle = wdLineStyleNone
    Next

Application.ScreenUpdating = True
End Sub

tangqingfu

谢谢wjhere兄!测试成功!
测试发现:
每行输入的小题数如果是1的话,运行就会出错,能否改进一下代码,使之能适合每行输入的小题数是1的情况!
PS:
能否使点号为无下划线形式?
再请wjhere兄帮看一下这个帖子:如何通过VBA将表格中的手动编号转为自动编号?
http://club.excelhome.net/thread-443054-1-1.html

[ 本帖最后由 tangqingfu 于 2009-6-4 22:14 编辑 ]

sylun

也可试试如下代码，基本思路是seq域和查找替换：
Sub test()
Dim a As Integer, b As Integer
Dim myRange As Range, c As Integer, w As Single
a = Val(InputBox("一行要输入几小题？", , 10))
b = Val(InputBox("要输入几行？", , 5))
Application.ScreenUpdating = False
Selection.Text = String(a * b, vbTab)
Set myRange = Selection.Range
With myRange
    .Fields.Add ActiveDocument.Range(.Start, .Start), wdFieldSequence, "a", False
    .Fields(1).Cut
    With .Find
        .MatchWildcards = True
        .Execute vbTab & "{" & a & "}", replacewith:="^&^p", Replace:=wdReplaceAll
        .Execute vbTab, replacewith:="^c.^&", Replace:=wdReplaceAll
        .Replacement.Font.Underline = wdUnderlineSingle
        .Execute vbTab, replacewith:="^32^&", Replace:=wdReplaceAll
    End With
    w = myRange.PageSetup.TextColumns.Width / a
    For c = 1 To a
        .ParagraphFormat.TabStops.Add c * w
    Next
    .Fields.Update
    '.Fields.Unlink  '取消域链接
    'If .Start <> .Paragraphs.First.Range.Start Then .InsertBefore vbCrLf
End With
Application.ScreenUpdating = True
End Sub