基于Word的图文试题库系统（一）

下面介绍一些我今年暑假编的一套题库系统，是在word上用VBA编的题库系统。所有的操作在Word上完成！主要的功能有题库的录入，题库的统计，随机抽取题库试题，试题难度和内容的安排，试卷的排版！想知道具体的东西，可以到我发布的资源下载。下面把我的代码公布：

    下面把题库文档，分布表文档中的代码公布：

 ‘===========================================================================

’题库文档中的VBA代码：

‘thisdocument中的代码是：
Private Sub Document_Open()
Call ActivateOrOpenDocument("分布表.doc")
End Sub
Private Sub Document_Close()
Documents("题库.doc").Save
Call ActivateOrCloseDocument("分布表.doc")
End Sub
Sub ActivateOrOpenDocument(lb)
    Dim doc As Document
    Dim docFound As Boolean

    For Each doc In Documents
        If InStr(1, doc.Name, lb, 1) Then
            doc.Activate
            docFound = True
            Exit For
        Else
            docFound = False
        End If
    Next doc
    If docFound = False Then Documents.Open FileName:=lb
End Sub

Sub ActivateOrCloseDocument(lb)
On Error Resume Next
    Dim doc As Document
    Dim docFound As Boolean
    For Each doc In Documents
        If InStr(1, doc.Name, lb, 1) Then
            doc.Activate
            docFound = True
            Exit For
        Else
            docFound = False
        End If
    Next doc
    If docFound = True Then ActiveDocument.Close
End Sub

’题库中模块中的代码：

'“题标涂色”子程序
'这个子程序用来给试题库中所有试题和答案的题标（也就是编号和参数部分）涂上颜色，这样使每道题、答案看起来醒目，界限分明。
'其中，试题题标涂粉红色，答案题标涂青绿色，用下面程序“题标涂色”实现。子程序“题标涂色”代码如下：

Sub 题标涂色()
    Call ts(" ", wdWhite)
    Call ts("`", wdPink)
    Call ts("~", wdTurquoise)
End Sub

'由于对试题和答案题标的涂色方法相同，所不同的只是试题和答案的起始标志不同（分别是“`”和“~”），填涂的颜色不同，所以可以用带有两个参数的子程序进行涂色操作。

'“ts”子程序
'这个子程序进行涂色操作。参数mark和x_color分别表示起始标志和要填涂的颜色。程序从文件开头向下查找起始标志，如果找到的话，则选中当前行，填涂指定的颜色，再继续查找下一个起始标志，进行同样的处理，直至文件结尾。代码如下：

Sub ts(mark, x_color)
    Selection.HomeKey Unit:=wdStory     '到文件头
    Selection.Find.Text = mark          '指定要查找的字符
    fd = Selection.Find.Execute         '进行查找
    Do While fd
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend     '选中当前行
        Selection.Range.HighlightColorIndex = x_color
        Selection.MoveRight Unit:=wdCharacter, Count:=1     '右移一个字符
        fd = Selection.Find.Execute                         '继续查找
    Loop
    Selection.HomeKey Unit:=wdStory                         '到文件头
End Sub

'“查找同题”子程序
'定义这个子程序的目的是为了检查题库中是否有重复出现的试题。在题库中选定任意一段文本，利用系统的环绕查找功能进行查找，如果找到相同的内容，光标将定位到相应的位置，如果没有重复内容，光标原地不动。子程序代码如下：

Sub 查找同题()
    tt = Selection.Text     '选定的文本
    With Selection.Find
        .Text = tt          '作为要查找的内容
        .Wrap = wdFindContinue   '环绕
        .Execute                 '执行查找
    End With
End Sub

‘=============================================================================

’分布表中的代码：

‘thisdocument中的代码：
Private Sub Document_Open()
Call ActivateOrOpenDocument("答案A.doc")
End Sub
Private Sub Document_Close()
Documents("试卷A.doc").Save
Call ActivateOrCloseDocument("答案A.doc")

End Sub

Sub ActivateOrOpenDocument(lb)
    Dim doc As Document
    Dim docFound As Boolean

    For Each doc In Documents
        If InStr(1, doc.Name, lb, 1) Then
            doc.Activate
            docFound = True
            Exit For
        Else
            docFound = False
        End If
    Next doc
    If docFound = False Then Documents.Open FileName:=lb
End Sub
Sub ActivateOrCloseDocument(lb)
On Error Resume Next
    Dim doc As Document
    Dim docFound As Boolean
    For Each doc In Documents
        If InStr(1, doc.Name, lb, 1) Then
            doc.Activate
            docFound = True
            Exit For
        Else
            docFound = False
        End If
    Next doc
    If docFound = True Then ActiveDocument.Close
End Sub

'模块一中的代码：
'题库信息统计
'    为了统计并显示出题库中各章、各种题型、各级难度的试题数量，各种题型、各级难度的总题数和总分数，各章的总题数和总分数，
'我们首先将统计结果存放到变量或数组中，然后再将变量或数组的内容添加到表格相应的单元格中。

'    另外，在统计组卷时要抽取的各种题型、各级难度的总题数和总分数，各章总题数和总分数以及在生成试卷过程中，也要用到相应的变量和数组。
'    这样，我们在“分布表”工程中插入“模块1”，在“模块1”中首先用下列语句声明模块级变量和数组：

Dim ts(18, 6, 3) As Integer     '题数（章号，题型，难度）
Dim zts(18) As Integer          '各章题数
Dim xns(18) As Integer          '各题型、难度的题数
Dim zfs(18) As Integer          '各章分数
Dim txf(6) As Integer           '各题型分数
Dim tb As Table                 '定义表类型变量
Dim txh(10) As Integer          '存放取题序号
Dim th                          '题号
Dim qts(18, 6, 3) As Integer    '取题数（章号，题型，难度）
Dim txm(6) As String          '各题型名
Dim txzs(6) As Integer          '各题型总题数
Dim txzf(6) As Integer           '各题型总分数

'“题库统计”代码如下：

Sub 题库统计()
    '将试题参数送数组或变量
    Erase ts, zts, xns, zfs, txf     '数组初始化
    Windows("题库.doc").Activate
    Application.ScreenUpdating = False  '关闭屏幕更新
    Options.DisplaySmartTagButtons = False  '关闭智能标记操作按钮
    Selection.HomeKey Unit:=wdStory         '光标到文件头
    Selection.Find.Text = "`"           '查找"标题"
    fnd = Selection.Find.Execute        '执行查找
    Do While fnd            '如果找到,循环
        Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend    '选中一个词
        Selection.MoveRight Unit:=wdCharacter, Count:=1                 '右移光标
        Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend    '选中下一个词
        tt = Selection.Text     '取出最右边4个字符
        If tt = "####" Then Exit Do     '遇到结束标记,结束循环
        zh = Val(Left(tt, 2))           '章号才
        tx = Asc(Mid(tt, 3, 1)) - 64    '题型
        nd = Val(Right(tt, 1))          '难度
        ts(zh, tx, nd) = ts(zh, tx, nd) + 1 '计数到数组
        zts(zh) = zts(zh) + 1               '统计各章题数
        xns((tx - 1) * 3 + nd) = xns((tx - 1) * 3 + nd) + 1 '统计各题型、难度的题数
        zj = zj + 1     '总题数
        Selection.MoveRight Unit:=wdCharacter, Count:=1 '右移一个字符
        fnd = Selection.Find.Execute    '继续查找
    Loop
    '删除第3、5、7、9、…、39行原有的信息
    Windows("分布表.doc").Activate
    Set tb = ActiveDocument.Tables(1)   '表格变量赋值
    For i = 3 To 39 Step 2
        Set rg = ActiveDocument.Range(tb.Cell(i, 4).Range.Start, _
        tb.Cell(i, 23).Range.End)       '设置一行20个单元格的区域
        rg.Delete Unit:=wdCharacter, Count:=1   '删除内容
    Next
    '删除第40行原有的信息
    Set rg = ActiveDocument.Range(tb.Cell(40, 4).Range.Start, _
    tb.Cell(40, 23).Range.End)          '设置一行20个单元格的区域
    rg.Delete Unit:=wdCharacter, Count:=1   '删除内容
    '将各题型分数送数组
    For k = 1 To 6
        s_txf = tb.Cell(k * 6 + 2, 1).Range.Text
        txf(k) = Val(s_txf)
    Next
    '填写表格中除39行以外的各“题库”行数据
    For r = 3 To 37 Step 2      '表格行循环
        For c = 4 To 21         '表格列循环
            cs = ts(c - 3, (r + 3) / 6, ((r - 3) / 2 Mod 3) + 1)
            If cs > 0 Then      '填充题数
                tb.Cell(r, c).Range.InsertAfter cs
            End If
            zfs(c - 3)