基于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

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) = zfs(c - 3) + cs * txf((r + 3) / 6) '累计各章分数
        Next
        cs = xns((r - 1) / 2) '当前行题数
        If cs > 0 Then
            tb.Cell(r, 22).Range.InsertAfter cs
        End If
        cs = cs * txf((r + 3) / 6) '当前行分数
        If cs > 0 Then
            tb.Cell(r, 23).Range.InsertAfter cs
        End If
        n_zfs = n_zfs + Val(cs)     '累计总分数
    Next
    '填写表格中各章总题数、总分数
    For c = 4 To 21     '按列循环
        cs = zts(c - 3)
        If cs > 0 Then      '填写章总题数
            tb.Cell(39, c).Range.InsertAfter cs
        End If
        cs = zfs(c - 3)
        If cs > 0 Then      '填写章总分数
            tb.Cell(40, c).Range.InsertAfter cs
        End If
    Next
    '填写题库总题数、总分数
    tb.Cell(39, 22).Range.InsertAfter zj    '填入总题数
    tb.Cell(40, 23).Range.InsertAfter n_zfs '填入总分数
    '收尾
    Options.DisplaySmartTagButtons = True   '打开智能标记操作按钮
    Application.ScreenUpdating = True       '恢复屏幕更新
    Selection.HomeKey Unit:=wdStory         '光标到文件头
    MsgBox "题库信息统计完毕！"
End Sub

'============================================================================================================================
Sub 抽取信息()
    '将各题型分数送入数组中
    Erase ts, zts, xns, zfs, txf '初始化数组
    Application.ScreenUpdating = False   '关闭屏幕更新
    Set tb = ActiveDocument.Tables(1)     '表格变量赋值
    For k = 1 To 6
        s_txf = tb.Cell(k * 6 + 2, 1).Range.Text
        txf(k) = Val(s_txf)
    Next
    '填写4--38各“抽取”行总题数和总分数
    For r = 4 To 38 Step 2          ' 表格行循环
        s_hts = 0      '当前行题数初值
        For c = 4 To 21
        ss = Val(tb.Cell(r, c).Range.Text)
        zj = zj + ss            '总题数
        s_hts = s_hts + ss      '当前行题数
        zts(c - 3) = zts(c - 3) + ss    '累加章题数
        zfs(c - 3) = zfs(c - 3) + ss * txf((r + 3) / 6) '累加章分数
        Next
      With tb.Cell(r, 22).Range
            .Delete                  '删除原值
            If s_hts > 0 Then
            .InsertAfter s_hts         '填入当前行总题数
            End If
      End With
      cs = s_hts * txf((r + 3) / 6)
      With tb.Cell(r, 23).Range
            .Delete               '删除原值
            If cs > 0 Then
            .InsertAfter cs
            End If
      End With
    n_zfs = n_zfs + Val(cs)      '累加总分数
    Next
    '填写各章“抽取”的总题数和总分数
    For c = 4 To 21
        cs = zts(c - 3)
        With tb.Cell(41, c).Range
               .Delete
               If Val(cs) > 0 Then
               .InsertAfter cs
               End If
        End With
        cs = zfs(c - 3)
        With tb.Cell(42, c).Range
               .Delete                 '删除原值
               If Val(cs) > 0 Then      '填入章总分数
               .InsertAfter cs
               End If
        End With
   Next
   '填写全部抽取总题数和分数
   With tb.Cell(41, 22).Range
          .Delete           '删除原值
          .InsertAfter zj       '填入总题数
   End With
   With tb.Cell(42, 23).Range
          .Delete
          .InsertAfter n_zfs     '填入总分数
   End With
   Application.ScreenUpdating = True '恢复屏幕更新
   MsgBox "抽取信息统计完毕！"
End Sub
Sub 生成试卷A()
'==========================================================================================================================
'根据“试题分布表”记录的题库各章，各题型，各难度的试题数量和计划抽取的试题数量，可以用下面的子程序“生成试卷”进行组卷，得到
'“试卷”文档和“答案”文档。
'===========================================================================================================================

'将题库中各章，各题型，各难度的题数送入数组ts，要提取的题数送数组qts
Set tb = ActiveDocument.Tables(1) '表格变量赋值
Application.ScreenUpdating = False '关闭屏幕更新
For zh = 1 To 18                '按章号循环
    For tx = 1 To 6             '按题型循环
        For nd = 1 To 3         '按难度循环
            ss = Val(tb.Cell((tx - 1) * 6 + 2 * nd + 1, zh + 3).Range.Text)
            ts(zh, tx, nd) = ss    ''题库中题数
            ss = Val(tb.Cell((tx - 1) * 6 + 2 * nd + 2, zh + 3).Range.Text)
            qts(zh, tx, nd) = ss    '要提取的题数
        Next
    Next
Next
'将各题型名，分数，要提取的各题型总题数，总分数送数组txm,txf,txzs,txzf
For k = 1 To 6
    s_txm = Trim(tb.Cell(k * 6 - 2, 1).Range.Text)       '取题型名（含回车）
    cd = Len(s_txm)                                      '求题型名长度
    txm(k) = Left(s_txm, cd - 2)                         '将各题型名送入数组
    txf(k) = Val(tb.Cell(k * 6 + 2, 1).Range.Text)       '将各题型分数送数组
    txzs(k) = Val(tb.Cell(k * 6 - 2, 22).Range.Text)     '将各题型总题数送数组
    txzs(k) = txzs(k) + Val(tb.Cell(k * 6, 22).Range.Text)
    txzs(k) = txzs(k) + Val(tb.Cell(k * 6 + 2, 22).Range.Text)
    txzf(k) = Val(tb.Cell(k * 6 - 2, 23).Range.Text)     '将各题型总分数送数组
    txzf(k) = txzf(k) + Val(tb.Cell(k * 6, 23).Range.Text)
    txzf(k) = txzf(k) + Val(tb.Cell(k * 6 + 2, 23).Range.Text)
Next
'从“题库”中提取标题
Windows("题库.doc").Activate
Selection.HomeKey Unit:=wdStory     '光标到文件头
Selection.EndKey Unit:=wdLine, Extend:=wdExtend '向右选一行，排除回车符
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
le = Len(Trim(Selection.Text))
kcm = Mid(Trim(Selection.Text), 1, (le - 3))    '标题送给变量kcm
'在“试卷”中添加标题
Call bt("试卷A.doc", kcm)
'在“答案”中添加标题
Call bt("答案A.doc", kcm)
'生成试卷和答案
s_th = "一二三四五六"
For tx = 1 To 6      '按题型循环
    'If txzs(tx) = 0 Then Break
    '建立试卷的题号和标号
    ss = Mid(s_th, tx, 1) & "、" & txm(tx)
    ss = ss & "（每题" & txf(tx) & "分共" & txzf(tx) & "分）"
    Windows("试卷A.doc").Activate
    Selection.TypeText Text:=ss
    Selection.TypeParagraph      '换行
    '建立答案的题号和标题
    Windows("答案A.doc").Activate
    Selection.TypeText Text:=ss
    Selection.TypeParagraph    '换行
    '对当前题型，按章号，难度顺序组卷
    th = 0 '题号初始值
    For zh = 1 To 18 '按章号循环
        For nd = 1 To 3   '按难度循环
            qts_n = qts(zh, tx, nd) '要提取的题数
            If qts_n > 0 Then
                ts_n = ts(zh, tx, nd) '题库中的题数
                Call sjs(ts_n, qts_n) '取qts_n个互不相同的随机数到全局数组txh()
                Call qt(qts_n, tx, zh, nd) '按数组txh()取qts_n道题到试卷和答案文档中
            End If
        Next
   Next
   '在试卷中添加当前题型结束标记，防止更换试题是越界
   Call txjs("试卷A.doc")
   '在答案中添加当前题型结束标题
   Call txjs("答案A.doc")
Next
'收尾
Windows("题库.doc").Activate
Selection.HomeKey Unit:=wdStory    '光标到文件头
Windows("试卷A.doc").Activate
Selection.HomeKey Unit:=wdStory    '光标到文件头
Application.ScreenUpdating = True   '恢复屏幕更新
End Sub
'子程序bt代码如下
Sub bt(lb, kcm)
'============================================================================================================================
'call bt("试卷",kcm)和call bt("答案",kcm)调用子程序bt，在“试卷”，“答案”文档中添加标题
'=============================================================================================================================
     Windows(lb).Activate
     Selection.WholeStory     '选中整个文档
     Selection.Delete Unit:=wdCharacter, Count:=1 '删除整个文档
     Selection.Font.Size = 16 '3号字
     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中
     Selection.TypeText Text:=kcm & lb     '标题
     Selection.TypeParagraph    '换行
     Selection.Font.Size = 12 '4号字
     Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify '两端对齐
     Selection.TypeParagraph     '换行

End Sub
'子程序sjs代码如下
Sub sjs(ts_n, qts_n)
'=========================================================================================================================
'在“生成试卷”子程序中，用语句call sjs(ts_n,qts_n) 产生1到ts_n之间的qts_n个互不相同的随机整数到全局数组txh()
'=========================================================================================================================
Randomize Timer    '随机数种子
k = 1
Do While k <= qts_n
         x = Int(Rnd * ts_n) + 1
         cf = 0
         For m = 1 To k - 1
             If txh(m) = x Then cf = 1 '有重复放弃
         Next
         If cf = 0 Then                 '不重复，有效
            txh(k) = x: k = k + 1
         End If
Loop
End Sub
'子程序qt代码如下
Sub qt(qts_n, tx, zh, nd)
'==============================================================================================================================
'在“生成试卷”子程序中，用语句call qt(qts_n,tx,zh,nd)按数组txh中指定的序号，在“题库”中抽取qts_n道满足题型，章号，难度条件
'的试题到试卷和答案文档中
'===============================================================================================================================
    Selection.Find.MatchWildcards = True   '使用通配符
    For k = 1 To qts_n
        Windows("题库.doc").Activate
        Selection.HomeKey Unit:=wdStory   '光标到文件头
        tcs = "`???? " & Right("0" & zh, 2) & Chr(64 + tx) & nd '题参数
        Selection.Find.Text = tcs    '指定查找内容
        For m = 1 To txh(k)
            Selection.Find.Execute         '执行txh(k)次查找
        Next
        Selection.MoveRight Unit:=wdCharacter, Count:=2 '光标移至下一行首
        Call copy_t("~")       '拷贝一题到剪贴板
        Windows("试卷A.doc").Activate
        th = th + 1
        Selection.TypeText Text:=Right(Str(th), 2) & "."
        Selection.TypeParagraph
        Selection.PasteAndFormat (wdPasteDefault)    '带格式粘贴
        Windows("题库.doc").Activate
        Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一行首
        Selection.EndKey Unit:=wdLine                       '光标移至行尾
        Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一行首
        Call copy_t("`")               '拷贝一题到剪贴板
        Windows("答案A.doc").Activate
        Selection.TypeText Text:=Right(Str(th), 2) & "."
        Selection.TypeParagraph
        Selection.PasteAndFormat (wdPasteDefault)   '带格式粘贴
   Next
End Sub
'子程序copy_t()代码如下:
Sub copy_t(mark)
'=================================================================================================================================
'子程序copy_t的功能是：从当前光标位置开始向下复制下向复制一道试题或答案。试题或者答案分别用不同的结束标记，用参数mark表示
'=================================================================================================================================
m = 0
Do
     Selection.MoveEnd Unit:=wdParagraph, Count:=1    '选一段
     ss = Left(Selection.Text, 1) '取出第一个字符
     m = m + 1
     Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一段首
Loop Until ss = mark '直到遇到标记
Selection.MoveLeft Unit:=wdCharacter, Count:=1   '光标移到上一行末
Selection.HomeKey Unit:=wdLine   '光标移到首行
Selection.MoveStart Unit:=wdParagraph, Count:=-m '向上选中m段
Selection.Copy
End Sub
'子程序txjs代码如下：
Sub txjs(lb)
'=============================================================================================================================
'在“生成试卷”子程序中，用语句call("试卷")和call("答案")调用子程序txjs,在“试卷”，和“答案”文档中添加当前题型结束标记，防止
'更换试题时越界出错。
Windows(lb).Activate
Selection.Font.Color = wdColorWhite '设置白色文本（使其不可见）
Selection.TypeText Text:="99."       '结束题号
Selection.TypeParagraph
Selection.TypeText Text:="`####"     '添加结束标记
Selection.TypeParagraph
Selection.Font.Color = wdColorBlack '设置黑色文本
End Sub

Sub 清空数据()
    Windows("分布表.doc").Activate
    Application.ScreenUpdating = False '关闭屏幕更新
    Selection.HomeKey Unit:=wdStory         '光标到文件头
    Set tb = ActiveDocument.Tables(1)   '表格变量赋值
    For i = 3 To 42
        Set rg = ActiveDocument.Range(tb.Cell(i, 4).Range.Start, _
        tb.Cell(i, 23).Range.End)       '设置一行20个单元格的区域
        rg.Delete Unit:=wdCharacter, Count:=1   '删除内容
    Next
    Application.ScreenUpdating = True
End Sub

模块二中的代码：

Sub 题型录入()
    Dim tb As Table
    Dim txm(6) As String
    Dim txfh(6) As String
    Dim txfs(6) As String
    Erase txm, txfh, txfs '数组初始化
    Windows("题库.doc").Activate
    Application.ScreenUpdating = False '关闭屏幕更新
    Options.DisplaySmartTagButtons = False '关闭智能标记操作按钮
    Selection.HomeKey Unit:=wdStory         '光标到文件头
    Set tb = ActiveDocument.Tables(1)   '表格变量赋值
    For i = 3 To 8
        txfh(i - 2) = Left(tb.Cell(i, 1).Range.Text, Len(tb.Cell(i, 1).Range.Text) - 2)
        txm(i - 2) = Left(tb.Cell(i, 2).Range.Text, Len(tb.Cell(i, 2).Range.Text) - 2)
        txfs(i - 2) = Left(tb.Cell(i, 3).Range.Text, Len(tb.Cell(i, 3).Range.Text) - 2)
    Next i
    Windows("分布表.doc").Activate
    Set tb = ActiveDocument.Tables(1)
    k = 1
    For i = 3 To 38 Step 6
        tb.Cell(i, 1).Range.Delete Unit:=wdCharacter, Count:=1
        tb.Cell(i, 1).Range.Text = txfh(k)
        tb.Cell(i + 1, 1).Range.Delete Unit:=wdCharacter, Count:=1
        tb.Cell(i + 1, 1).Range.Text = txm(k)
        tb.Cell(i + 5, 1).Range.Delete Unit:=wdCharacter, Count:=1
        tb.Cell(i + 5, 1).Range.Text = txfs(k)
        k = k + 1
    Next
    Options.DisplaySmartTagButtons = True   '打开智能标记操作按钮
    Application.ScreenUpdating = True       '恢复屏幕更新
    Selection.HomeKey Unit:=wdStory         '光标到文件头
End Sub

‘模块三中的代码：

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

'子程序qt代码如下
Sub qt(qts_n, tx, zh, nd)
'==============================================================================================================================
'在“生成试卷”子程序中，用语句call qt(qts_n,tx,zh,nd)按数组txh中指定的序号，在“题库”中抽取qts_n道满足题型，章号，难度条件
'的试题到试卷和答案文档中
'===============================================================================================================================
    Selection.Find.MatchWildcards = True   '使用通配符
    For k = 1 To qts_n
        Windows("题库.doc").Activate
        Selection.HomeKey Unit:=wdStory   '光标到文件头
        tcs = "`???? " & Right("0" & zh, 2) & Chr(64 + tx) & nd '题参数
        Selection.Find.Text = tcs    '指定查找内容
        For m = 1 To txh(k)
            Selection.Find.Execute         '执行txh(k)次查找
        Next
        Selection.MoveRight Unit:=wdCharacter, Count:=2 '光标移至下一行首
        Call copy_t("~")       '拷贝一题到剪贴板
        Windows("试卷B.doc").Activate
        th = th + 1
        Selection.TypeText Text:=Right(Str(th), 2) & "."
        Selection.TypeParagraph
        Selection.PasteAndFormat (wdPasteDefault)    '带格式粘贴
        Windows("题库.doc").Activate
        Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一行首
        Selection.EndKey Unit:=wdLine                       '光标移至行尾
        Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一行首
        Call copy_t("`")               '拷贝一题到剪贴板
        Windows("答案B.doc").Activate
        Selection.TypeText Text:=Right(Str(th), 2) & "."
        Selection.TypeParagraph
        Selection.PasteAndFormat (wdPasteDefault)   '带格式粘贴
   Next
End Sub

Sub 生成试卷B()
Set tb = ActiveDocument.Tables(1) '表格变量赋值
Application.ScreenUpdating = False '关闭屏幕更新
For zh = 1 To 18                '按章号循环
    For tx = 1 To 6             '按题型循环
        For nd = 1 To 3         '按难度循环
            ss = Val(tb.Cell((tx - 1) * 6 + 2 * nd + 1, zh + 3).Range.Text)
            ts(zh, tx, nd) = ss    ''题库中题数
            ss = Val(tb.Cell((tx - 1) * 6 + 2 * nd + 2, zh + 3).Range.Text)
            qts(zh, tx, nd) = ss    '要提取的题数
        Next
    Next
Next
'将各题型名，分数，要提取的各题型总题数，总分数送数组txm,txf,txzs,txzf
For k = 1 To 6
    s_txm = Trim(tb.Cell(k * 6 - 2, 1).Range.Text)       '取题型名（含回车）
    cd = Len(s_txm)                                      '求题型名长度
    txm(k) = Left(s_txm, cd - 2)                         '将各题型名送入数组
    txf(k) = Val(tb.Cell(k * 6 + 2, 1).Range.Text)       '将各题型分数送数组
    txzs(k) = Val(tb.Cell(k * 6 - 2, 22).Range.Text)     '将各题型总题数送数组
    txzs(k) = txzs(k) + Val(tb.Cell(k * 6, 22).Range.Text)
    txzs(k) = txzs(k) + Val(tb.Cell(k * 6 + 2, 22).Range.Text)
    txzf(k) = Val(tb.Cell(k * 6 - 2, 23).Range.Text)     '将各题型总分数送数组
    txzf(k) = txzf(k) + Val(tb.Cell(k * 6, 23).Range.Text)
    txzf(k) = txzf(k) + Val(tb.Cell(k * 6 + 2, 23).Range.Text)
Next
'从“题库”中提取标题
Windows("题库.doc").Activate
Selection.HomeKey Unit:=wdStory     '光标到文件头
Selection.EndKey Unit:=wdLine, Extend:=wdExtend '向右选一行，排除回车符
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
le = Len(Trim(Selection.Text))
kcm = Mid(Trim(Selection.Text), 1, (le - 3))   '标题送给变量kcm
'在“试卷”中添加标题
Call bt("试卷B.doc", kcm)
'在“答案”中添加标题
Call bt("答案B.doc", kcm)
'生成试卷和答案
s_th = "一二三四五六"
For tx = 1 To 6      '按题型循环
    'If txzs(tx) = 0 Then Break
    '建立试卷的题号和标号
    ss = Mid(s_th, tx, 1) & "、" & txm(tx)
    ss = ss & "（每题" & txf(tx) & "分共" & txzf(tx) & "分）"
    Windows("试卷B.doc").Activate
    Selection.TypeText Text:=ss
    Selection.TypeParagraph      '换行
    '建立答案的题号和标题
    Windows("答案B.doc").Activate
    Selection.TypeText Text:=ss
    Selection.TypeParagraph    '换行
    '对当前题型，按章号，难度顺序组卷
    th = 0 '题号初始值
    For zh = 1 To 18 '按章号循环
        For nd = 1 To 3   '按难度循环
            qts_n = qts(zh, tx, nd) '要提取的题数
            If qts_n > 0 Then
                ts_n = ts(zh, tx, nd) '题库中的题数
                Call sjs(ts_n, qts_n) '取qts_n个互不相同的随机数到全局数组txh()
                Call qt(qts_n, tx, zh, nd) '按数组txh()取qts_n道题到试卷和答案文档中
            End If
        Next
   Next
   '在试卷中添加当前题型结束标记，防止更换试题是越界
   Call txjs("试卷B.doc")
   '在答案中添加当前题型结束标题
   Call txjs("答案B.doc")
Next
'收尾
Windows("题库.doc").Activate
Selection.HomeKey Unit:=wdStory    '光标到文件头
Windows("试卷B.doc").Activate
Selection.HomeKey Unit:=wdStory    '光标到文件头
Application.ScreenUpdating = True   '恢复屏幕更新
End Sub

'子程序bt代码如下
Sub bt(lb, kcm)
'============================================================================================================================
'call bt("试卷",kcm)和call bt("答案",kcm)调用子程序bt，在“试卷”，“答案”文档中添加标题
'=============================================================================================================================
     Windows(lb).Activate
     Selection.WholeStory     '选中整个文档
     Selection.Delete Unit:=wdCharacter, Count:=1 '删除整个文档
     Selection.Font.Size = 16 '3号字
     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中
     Selection.TypeText Text:=kcm & lb     '标题
     Selection.TypeParagraph    '换行
     Selection.Font.Size = 12 '4号字
     Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify '两端对齐
     Selection.TypeParagraph     '换行

End Sub
'子程序sjs代码如下
Sub sjs(ts_n, qts_n)
'=========================================================================================================================
'在“生成试卷”子程序中，用语句call sjs(ts_n,qts_n) 产生1到ts_n之间的qts_n个互不相同的随机整数到全局数组txh()
'=========================================================================================================================
Randomize Timer    '随机数种子
k = 1
Do While k <= qts_n
         x = Int(Rnd * ts_n) + 1
         cf = 0
         For m = 1 To k - 1
             If txh(m) = x Then cf = 1 '有重复放弃
         Next
         If cf = 0 Then                 '不重复，有效
            txh(k) = x: k = k + 1
         End If
Loop
End Sub
'子程序copy_t()代码如下:
Sub copy_t(mark)
'=================================================================================================================================
'子程序copy_t的功能是：从当前光标位置开始向下复制下向复制一道试题或答案。试题或者答案分别用不同的结束标记，用参数mark表示
'=================================================================================================================================
m = 0
Do
     Selection.MoveEnd Unit:=wdParagraph, Count:=1    '选一段
     ss = Left(Selection.Text, 1) '取出第一个字符
     m = m + 1
     Selection.MoveRight Unit:=wdCharacter, Count:=1 '光标移至下一段首
Loop Until ss = mark '直到遇到标记
Selection.MoveLeft Unit:=wdCharacter, Count:=1   '光标移到上一行末
Selection.HomeKey Unit:=wdLine   '光标移到首行
Selection.MoveStart Unit:=wdParagraph, Count:=-m '向上选中m段
Selection.Copy
End Sub
'子程序txjs代码如下：
Sub txjs(lb)
'=============================================================================================================================
'在“生成试卷”子程序中，用语句call("试卷")和call("答案")调用子程序txjs,在“试卷”，和“答案”文档中添加当前题型结束标记，防止
'更换试题时越界出错。
Windows(lb).Activate
Selection.Font.Color = wdColorWhite '设置白色文本（使其不可见）
Selection.TypeText Text:="99."       '结束题号
Selection.TypeParagraph
Selection.TypeText Text:="`####"     '添加结束标记
Selection.TypeParagraph
Selection.Font.Color = wdColorBlack '设置黑色文本
End Sub

基于Word的图文试题库系统（一）相关推荐

VB通用C++试题库系统的设计与开发
word完整版可点击如下下载>>>>>>>> VB通用C++试题库系统的设计与开发(论文+源代码).rar-VB文档类资源-CSDN下载1.资源内容:毕 ...
万维考试系统python题库答案_万维试题库系统官方下载
万维试题库管理系统是一款相当出色的考试软件,软件拥有很多功能如课程定义,题型支持.试题批量识别导入,雷同试题检测,随机组卷和手工组卷流程控制,透明压缩,双向缓冲处理,数据导入导出共享,相当实用. 基本 ...
[源码和文档分享]基于JSP实现的试题库管理系统
1 引言 1.1 编写目的该需求分析报告用于软件开发小组对基于WEB的软件工程课程试题库管理系统这一课题的开发过程.明确了课题开发的目的与要求,介绍了该系统的所有功能以及适用范围. 1.2 项目背景 ...
计算机操作系统试题库系统论文,计算机操作系统试题库（原）
13．一个进程的大小为5个页面,为它分配了四个物理块.当前每个块的情况如下表所示(都为十进制数,且从0开始计数.).当虚页4发生缺页时,使用下列的页面置换算法,哪一个物理块将被换出?并解释原因．(10 ...
计算机应用基础基础系统,计算机应用基础试题库系统分析
摘要:"计算机应用基础"课程是现代大学教育中的公共必修课,文章分析了传统的考试存在的不足,然后对试题库的系统进行了分析与设计,以促进教学发展. 关键词:计算机应用基础:试题库:必修 ...
自动组卷系统C语言,模块化思想在试题库组卷系统中的应用--以C语言程序设计课程为例 (1).pdf...
2014年6月伊犁师范学院学报 (自然科学版) Jun．2014 第 8卷第 2期 JournalofYiliNormalUniversity(NaturalScienceEdition) V0| ...
asp毕业设计——基于asp+access的精品在线试题库设计与实现（毕业论文+程序源码）——精品在线试题库
基于asp+access的精品在线试题库设计与实现(毕业论文+程序源码) 大家好,今天给大家介绍基于asp+access的精品在线试题库设计与实现,文章末尾附有本毕业设计的论文和源码下载地址哦.需要下 ...
springboot《计算机网络原理》课程试题库管理系统开发毕业设计-附源码271129
Springboot<计算机网络原理>课程试题库管理系统摘要信息化社会内需要与之针对性的信息获取途径,但是途径的扩展基本上为人们所努力的方向,由于站在的角度存在偏差,人们经常能够获得 ...
基于JAVA网上专家门诊预约系统计算机毕业设计源码+数据库+lw文档+系统+部署
基于JAVA网上专家门诊预约系统计算机毕业设计源码+数据库+lw文档+系统+部署基于JAVA网上专家门诊预约系统计算机毕业设计源码+数据库+lw文档+系统+部署本源码技术栈: 项目架构:B/S架构 ...

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

基于Word的图文试题库系统（一）相关推荐

最新文章

热门文章