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

‘模块三中的代码：

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

' 另外，在统计组卷时要抽取的各种题型、各级难度的总题数和总分数，各章总题数和总分数以及在生成试卷过程中，也要用到相应的变量和数组。
' 这样，我们在“分布表”工程中插入“模块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 '各题型总分数

'子程序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