如何做一个题库软件，比如计算等级模拟考试软件，机动车科目一考试。这些软件都需要有题库。那么怎么从word中录入这些题库呢？

有如何把Access里面的题目导出到word 方便阅读呢？

如下示例，可以快读导入题库，导出试题。 

详细源码：

Private Sub 导入题库_Click()Dim doc As New Word.ApplicationDim myname As StringDim str As StringDim i As Long, m As LongDim rs As New ADODB.RecordsetDim sql As StringDim n As String, p As Boolean, q As LongOn Error GoTo err_错误sql = "select * from 题库子表"rs.Open sql, CurrentProject.Connection, adOpenKeyset, adLockOptimisticmyname = GetFolderdoc.Documents.Open FileName:=mynamedoc.Visible = Truedoc.Activatedoc.Documents(myname).Activatem = doc.Documents(myname).Paragraphs.CountFor 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 IfNextMe.题库子窗体.RequeryMe.编辑子窗体.RequerySet doc = Nothingrs.CloseExit_退出:Exit Suberr_错误:    doc.Quit    MsgBox "出现操作错误，请检查。"Resume Exit_退出:End SubPrivate Sub 导出试卷_Click()Dim myname As StringDim myfolder As StringDim x As BooleanDim myFSO As New FileSystemObjectDim doc As New Word.ApplicationDim i As Long, j As Long, m As LongDim myID As LongDim strsql As StringDim rs1 As New ADODB.RecordsetDim sql1 As StringDim rs2 As New ADODB.RecordsetDim sql2 As StringOn 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 strsqlSet doc = NothingSet myFSO = NothingSet myFile = NothingExit_退出:Exit Suberr_错误:    doc.Quit    MsgBox "出现操作错误，请检查。"Resume Exit_退出:End Sub