如何做一个题库软件，比如计算等级模拟考试软件，机动车科目一考试。这些软件都需要有题库。那么怎么从word中录入这些题库呢？
有如何把Access里面的题目导出到word 方便阅读呢？
如下示例，可以快读导入题库，导出试题。
Dim doc As New Word.Application
Dim myname As String
Dim str As String
Dim i As Long, m As Long
Dim rs As New ADODB.Recordset
Dim sql As String
Dim n As String, p As Boolean, q As Long
On Error GoTo err_错误
sql = "select * from 题库子表"
rs.Open sql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
myname = GetFolder
doc.Documents.Open FileName:=myname
doc.Visible = True
doc.Activate
doc.Documents(myname).Activate
m = doc.Documents(myname).Paragraphs.Count
For i = 2 To m
doc.Documents(myname).Paragraphs(i).Range.Select
str = doc.Selection.Text
p = InStr(str, "一、判断题") > 0
p = p Or InStr(str, "二、填空题") > 0
p = p Or InStr(str, "三、选择题") > 0
p = p Or InStr(str, "四、简答题") > 0
If p = True Then
If InStr(str, "一、判断题") > 0 Then q = 1
If InStr(str, "二、填空题") > 0 Then q = 2
If InStr(str, "三、选择题") > 0 Then q = 3
If InStr(str, "四、简答题") > 0 Then q = 4
Else
doc.Selection.Find.Execute FindText:="题目：", Forward:=True
If doc.Selection.Text = "题目：" Then
n = "题目："
doc.Documents(myname).Paragraphs(i).Range.Select
rs.AddNew
rs("题库ID") = 1
rs("题型ID") = q
rs("题目") = str
If InStr(str, "题目：链接：") > 0 Then
doc.Selection.Copy
rs("链接") = "请通过复制拷贝方式链接题目！"
End If
rs.Update
Else
doc.Selection.Find.Execute FindText:="答案：", Forward:=True
If doc.Selection.Text = "答案：" Then
n = "答案："
rs("答案") = str
rs.Update
Else
If n = "题目：" Then
rs("题目") = rs("题目") & Chr(10) & str
rs.Update
Else
rs("答案") = rs("答案") & Chr(10) & str
rs.Update
End If
End If
End If
End If
Next
Me.题库子窗体.Requery
Me.编辑子窗体.Requery
Set doc = Nothing
rs.Close
Exit_退出:
Exit Sub
err_错误:
doc.Quit
MsgBox "出现操作错误，请检查。"
Resume Exit_退出:
End Sub
Private Sub 导出试卷_Click()
Dim myname As String
Dim myfolder As String
Dim x As Boolean
Dim myFSO As New FileSystemObject
Dim doc As New Word.Application
Dim i As Long, j As Long, m As Long
Dim myID As Long
Dim strsql As String
Dim rs1 As New ADODB.Recordset
Dim sql1 As String
Dim rs2 As New ADODB.Recordset
Dim sql2 As String
On Error GoTo err_错误
sql1 = "select * from 题型表"
rs1.Open sql1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
'---------------------------------------------------
'建立或打开WORD文件
doc.Visible = True
myname = InputBox("请输入试卷名称：") & ".doc"
myfolder = CurrentProject.Path & "\试卷\"
x = myFSO.FileExists(myfolder & myname)
If Not (x) Then
doc.Documents.Add
doc.Activate
doc.ActiveDocument.SaveAs FileName:=myfolder & myname
Else
doc.Documents.Open FileName:=myfolder & myname
doc.Activate
End If
'----------------------------------------------------
'导出ACCESS数据
doc.Selection.WholeStory '全选
doc.Selection.Delete Unit:=wdCharacter, Count:=1 '删除
doc.Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
doc.Selection.TypeText Text:="试卷名称：" & myname
doc.Selection.TypeParagraph
doc.Selection.TypeParagraph
'导出题目
For i = 1 To rs1.RecordCount
sql2 = "select * from 题库子表 where 选中=yes and 题型ID=" & rs1("题型ID")
rs2.Open sql2, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
doc.Selection.TypeText Text:=i & "、" & rs1("题型名称")
doc.Selection.TypeParagraph
For j = 1 To rs2.RecordCount
doc.Selection.TypeText Text:="（" & j & "）"
If IsNull(rs2("链接")) = True Then
doc.Selection.TypeText Text:=Mid(rs2("题目"), 4)
Else
doc.Selection.Font.Color = wdColorRed
doc.Selection.TypeText Text:="提示：该题有链接内容，请手工导入。"
doc.Selection.Font.Color = wdColorAutomatic
End If
doc.Selection.TypeParagraph
rs2.MoveNext
Next
rs2.Close
rs1.MoveNext
Next
'导出答案
doc.Selection.TypeParagraph
doc.Selection.TypeParagraph
doc.Selection.TypeText Text:="试卷答案："
doc.Selection.TypeParagraph
rs1.MoveFirst
For i = 1 To rs1.RecordCount
sql2 = "select * from 题库子表 where 选中=yes and 题型ID=" & rs1("题型ID")
rs2.Open sql2, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
doc.Selection.TypeText Text:=i & "、" & rs1("题型名称")
doc.Selection.TypeParagraph
For j = 1 To rs2.RecordCount
doc.Selection.TypeText Text:="（" & j & "）"
If IsNull(rs2("链接")) = True Then
doc.Selection.TypeText Text:=Mid(rs2("答案"), 4)
Else
doc.Selection.Font.Color = wdColorRed
doc.Selection.TypeText Text:="提示：该题有链接内容，请手工导入。"
doc.Selection.Font.Color = wdColorAutomatic
End If
doc.Selection.TypeParagraph
rs2.MoveNext
Next
rs2.Close
rs1.MoveNext
Next
doc.Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
wdAlignPageNumberCenter, FirstPage:=True '设置页码
doc.Documents.Save '保存
'取消题库表选中标识
strsql = "UPDATE 题库子表 SET 题库子表.选中 = no "
strsql = strsql & "WHERE (((题库子表.选中)=Yes));"
CurrentDb.Execute strsql
Set doc = Nothing
Set myFSO = Nothing
Set myFile = Nothing
Exit_退出:
Exit Sub
err_错误:
doc.Quit
MsgBox "出现操作错误，请检查。"
Resume Exit_退出:
End Sub
