在Word中从Access数据库随机抽取试题制作试卷的方法
在Word中，从Access数据库的对应表中，随机抽取试题并制作成一定版面的试卷，我作了一些尝试，试卷要求：生成大题及对应的分值，题目随机抽取，单选、多选答案也要随机变化（其中含有“以上”字样开头的，必须是第三个或者第四个答案），并根据抽取的题目情况，生成对应的参考答案文件（文件是文本文件）。
一、数据库
其中blankQt、judgeQt、multiQt、singleQt结构如上，分别装的是填空题、判断题、多选题、单选题内容。数据可以自己根据需要填写。
二、VBA窗体
利用Word自身所带的VBA，制作窗体如下：
三、VBA代码
1.模块中代码
Sub startMacro()
optForm.Show
End Sub
Sub readTable(ByVal sBT As String, ByVal sST As String, ByVal iST As Integer, ByVal iMT As Integer, ByVal iJT As Integer, ByVal iBT As Integer)
Dim tm(3000) As String, bx(3000, 4) As String, da(3000) As String, i As Integer, j As Integer, cnSq As String, tmCnt As Integer
Dim subNo() As Integer, xHs() As Integer
Dim tmpTm As String, tmpBx As String, tmpDa As String, tABCD As String, tmpZM As String, outDa As String, qtTitle As String, da1 As String
Dim conn As ADODB.Connection
Set conn = New ADODB.Connection
Dim cnSr As String
cnSr = "driver={microsoft access driver (*.mdb, *.accdb)};dbq=" & ThisDocument.Path & "\nopapertest.mdb"
conn.Open cnSr
Dim refDaFile As String
refDaFile = ThisDocument.Path & "\" & sST & "(参考答案).txt"
Open refDaFile For Output As #1
Print #1, sBT
Print #1, sST & "(参考答案)" & vbCrLf
setDocTitle sBT, sST '设置标题（一二级）
Dim sRs As ADODB.Recordset '对单选题进行处理
Set sRs = New ADODB.Recordset
cnSq = "select 题目,备选A,备选B,备选C,备选D,答案 from singleQt"
sRs.Open cnSq, conn
i = 0
Do While Not sRs.EOF
i = i + 1
tm(i) = sRs(0)
For j = 1 To 4
bx(i, j) = sRs(j)
Next
da(i) = bx(i, sRs(5) * 1)
sRs.MoveNext
Loop
tmCnt = i
ReDim subNo(iST), xHs(4)
Dim ySBx(4) As String
randArray subNo, iST, tmCnt
qtTitle = "一、单项选择题（每小题3分，有" & iST & "个小题，共" & 3 * iST & "分)"
Selection.TypeText qtTitle & vbCrLf
Print #1, qtTitle
Print #1, "1-5: ";
For i = 1 To iST
'Selection.TypeText xHs(1) & xHs(2) & xHs(3) & xHs(4) & vbCrLf
tmpTm = tm(subNo(i))
tmpDa = da(subNo(i))
Selection.TypeText i & "、" & tmpTm & vbCrLf
ySBx(1) = bx(subNo(i), 1)
ySBx(2) = bx(subNo(i), 2)
ySBx(3) = bx(subNo(i), 3)
ySBx(4) = bx(subNo(i), 4)
If InStr(ySBx(4), "以上") > 0 And InStr(ySBx(3), "以上") > 0 Then
randArray xHs, 2, 2
xHs(3) = 3: xHs(4) = 4
ElseIf InStr(ySBx(4), "以上") > 0 Then
randArray xHs, 3, 3
xHs(4) = 4
Else
randArray xHs, 4, 4
End If
For j = 1 To 4
tmpBx = ySBx(xHs(j))
If j = 1 Then da1 = tmpBx
tABCD = Chr(64 + j)
Select Case Len(da1)
Case Is <= 8
If j Mod 4 <> 0 Then
outDa = tmpBx & vbTab
Else
outDa = tmpBx & vbCrLf
End If
Case Is <= 16
If j Mod 2 <> 0 Then
outDa = tmpBx & vbTab
Else
outDa = tmpBx & vbCrLf
End If
Case Else
outDa = tmpBx & vbCrLf
End Select
Selection.TypeText tABCD & "." & outDa
If tmpBx = tmpDa Then tmpZM = tABCD
Next
Print #1, tmpZM;
If i = iST Or i Mod 20 = 0 Then
If i = iST Then
Print #1, ""
'Print #1, (i \ 5) * 5 + 1 & "-" & iST & ": ";
Else
Print #1, ""
access数据库生成网页版 Print #1, (i \ 5) * 5 + 1 & "-" & ((i \ 5) + 1) * 5 & ": ";
End If
Else
If i Mod 5 = 0 And i < iST - 5 Then
Print #1, vbTab & (i \ 5) * 5 + 1 & "-" & ((i \ 5) + 1) * 5 & ": ";
End If
End If
Next
sRs.Close
Set sRs = Nothing
Dim mRs As ADODB.Recordset '对多选题进行处理
Set mRs = New ADODB.Recordset
cnSq = "select 题目,备选A,备选B,备选C,备选D,答案 from multiQt"
mRs.Open cnSq, conn
i = 0
Do While Not mRs.EOF
i = i + 1
tm(i) = mRs(0)
da(i) = ""
For j = 1 To 4
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论