基於Word圖文試題庫系統（二）

下面介紹一些我今年暑假編的一套題庫系統，是在word上用VBA編的題庫系統。所有的操作在Word上完成！主要的功能有題庫的錄入，題庫的統計，隨機抽取題庫試題，試題難度和內容的安排，試卷的排版！想知道具體的東西，可以到我發布的資源下載。下面把My Code公布：

    下面把試卷A，試卷B，答案A，答案B文檔的代碼公布：

 ‘===========================================================================

’試卷A的代碼：
’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
‘模組中的代碼：
'"查看原體"子程式的作用就是根據“試卷”文檔中當前行的試題編號，到“題庫”文檔中尋找和定位指定的試題，代碼如下：
Sub 查看原體()
    Selection.HomeKey Unit:=wdLine   '游標到行首
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend  '選中當前行
    tt = Left(Selection.Text, 1)   '取出最左邊1個字元
    If tt <> "`" Then Exit Sub     '不是題標行，退出子程式
    xh = Left(Selection.Text, 5) '取出題編號
    Windows("題庫.doc").Activate
    Selection.HomeKey Unit:=wdStory  '游標到標頭檔
    Selection.Find.Text = xh    '尋找指定序號的試題
    Selection.Find.Execute      '執行尋找
    Selection.EndKey Unit:=wdLine   '游標移到行末尾
End Sub
'=========================================================================================================================
'更換試題子程式的作用是用“題庫”中相同參數的其他試題替換“試卷”文檔的當前試題，同時替換“答案”文檔對應試題的答案
'==========================================================================================================================
Sub 更換試題()
    Selection.HomeKey Unit:=wdLine   '游標到行首
    Selection.MoveRight Unit:=wdCharacter, Count:=10, Extend:=wdExtend      '選中10個字元
    tt = Left(Selection.Text, 1)        '取出最左邊一個字元
    If tt <> "`" Then Exit Sub
    tt = Right(Selection.Text, 4)       '取出試題參數
    t_no = Mid(Selection.Text, 2, 4)    '取出試題編號
    Selection.HomeKey Unit:=wdLine
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    t_xh = Selection.Text               '取出試題序號
    Selection.MoveDown Unit:=wdLine
    Selection.EndKey Unit:=wdLine       '游標移至行尾
    Selection.MoveRight Unit:=wdCharacter, Count:=1     '游標移至下一行首
    Call sele_t("`")                    '選中一個題的原題
    Windows("題庫.doc").Activate
    Selection.Find.Text = tt           '尋找指定參數的試題
    Selection.Find.Wrap = 1             '自動迴圈查詢
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=2  '游標移到下一行首
    Call copy_t("~")                    '拷貝一題到剪下板
    Selection.MoveRight Unit:=wdCharacter, Count:=1     '游標移至下一行首
    Selection.EndKey Unit:=wdLine           '游標移至行尾
    Selection.MoveRight Unit:=wdCharacter, Count:=1   '游標移至下一行首
    Windows("試卷A.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)   '帶格式粘貼
    Selection.Find.Text = "`"
    Selection.Find.Forward = False       '向上尋找，回退到當前題標處
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1 '游標移右移
    Selection.Find.Forward = True       '恢複向下尋找方式
    Windows("答案A.doc").Activate
    Selection.HomeKey Unit:=wdStory
    Selection.Find.Text = t_xh & "~" & t_no   '尋找指定題號的試題
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Call sele_t("~")            '選中一個題的答案
    Windows("題庫.doc").Activate
    Call copy_t("`")
    Windows("答案A.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Windows("試卷A.doc").Activate
End Sub
'===============================================================================================================================
'sele_t子程式的功能是： 從當前行開始向下選擇到標記（mark）減一行。用來選中一道試題和答案。代碼如下：
'===============================================================================================================================
Sub sele_t(mark)
    Call sele_p(mark, m)
    Selection.MoveLeft Unit:=wdCharacter, Count:=1  '游標移到上一行末
    Selection.HomeKey Unit:=wdLine
    m = m - 1
    Selection.MoveStart Unit:=wdParagraph, Count:=-m   '向上選中m-1段
End Sub
Sub sele_p(mark, m)
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
End Sub
Sub copy_t(mark)
Call sele_p(mark, m)
Selection.MoveStart Unit:=wdParagraph, Count:=-m
Selection.Copy
End Sub
Sub 刪除參數()
Call dele_c("試卷A.doc", "`")
Call dele_c("答案A.doc", "~")
Windows("試卷A.doc").Activate
End Sub
Sub dele_c(lb, mark)
Windows(lb).Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.Text = mark
fd = Selection.Find.Execute
Do While fd
   Selection.EndKey Unit:=wdLine, Extend:=wdExtend
   tt = Left(Selection.Text, 5)
   Selection.Delete Unit:=wdCharacter, Count:=1
   If tt <> "`####" Then
       Call dele_b
   End If
   fd = Selection.Find.Execute
Loop
Selection.HomeKey Unit:=wdStory
End Sub
Sub dele_b()
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
zfm = Asc(Selection.Text)
k = 0
Do While k < 5 And (zfm = 13 Or zfm = 32 Or zfm = -24159)
   Selection.Delete Unit:=wdCharacter, Count:=1
   Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
   zfm = Asc(Selection.Text)
   k = k + 1
Loop
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=" "
End Sub

’======================================================================================
‘答案A文檔中的代碼：
’thisdocument 中的代碼：
Private Sub Document_Open()
Call ActivateOrOpenDocument("試卷B.doc")
End Sub
Private Sub Document_Close()
Documents("答案A.doc").Save
Call ActivateOrCloseDocument("試卷B.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

‘========================================================================================

’試卷B中的代碼：
thisdocument中的代碼：
Private Sub Document_Open()
Call ActivateOrOpenDocument("答案B.doc")
End Sub
Private Sub Document_Close()
Documents("試卷B.doc").Save
Call ActivateOrCloseDocument("答案B.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 查看原體()
    Selection.HomeKey Unit:=wdLine   '游標到行首
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend  '選中當前行
    tt = Left(Selection.Text, 1)   '取出最左邊1個字元
    If tt <> "`" Then Exit Sub     '不是題標行，退出子程式
    xh = Left(Selection.Text, 5) '取出題編號
    Windows("題庫.doc").Activate
    Selection.HomeKey Unit:=wdStory  '游標到標頭檔
    Selection.Find.Text = xh    '尋找指定序號的試題
    Selection.Find.Execute      '執行尋找
    Selection.EndKey Unit:=wdLine   '游標移到行末尾
End Sub
'=========================================================================================================================
'更換試題子程式的作用是用“題庫”中相同參數的其他試題替換“試卷”文檔的當前試題，同時替換“答案”文檔對應試題的答案
'==========================================================================================================================
Sub 更換試題()
    Selection.HomeKey Unit:=wdLine   '游標到行首
    Selection.MoveRight Unit:=wdCharacter, Count:=10, Extend:=wdExtend      '選中10個字元
    tt = Left(Selection.Text, 1)        '取出最左邊一個字元
    If tt <> "`" Then Exit Sub
    tt = Right(Selection.Text, 4)       '取出試題參數
    t_no = Mid(Selection.Text, 2, 4)    '取出試題編號
    Selection.HomeKey Unit:=wdLine
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    t_xh = Selection.Text               '取出試題序號
    Selection.MoveDown Unit:=wdLine
    Selection.EndKey Unit:=wdLine       '游標移至行尾
    Selection.MoveRight Unit:=wdCharacter, Count:=1     '游標移至下一行首
    Call sele_t("`")                    '選中一個題的原題
    Windows("題庫.doc").Activate
    Selection.Find.Text = tt           '尋找指定參數的試題
    Selection.Find.Wrap = 1             '自動迴圈查詢
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=2  '游標移到下一行首
    Call copy_t("~")                    '拷貝一題到剪下板
    Selection.MoveRight Unit:=wdCharacter, Count:=1     '游標移至下一行首
    Selection.EndKey Unit:=wdLine           '游標移至行尾
    Selection.MoveRight Unit:=wdCharacter, Count:=1   '游標移至下一行首
    Windows("試卷B.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)   '帶格式粘貼
    Selection.Find.Text = "`"
    Selection.Find.Forward = False       '向上尋找，回退到當前題標處
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1 '游標移右移
    Selection.Find.Forward = True       '恢複向下尋找方式
    Windows("答案B.doc").Activate
    Selection.HomeKey Unit:=wdStory
    Selection.Find.Text = t_xh & "~" & t_no   '尋找指定題號的試題
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=2
    Call sele_t("~")            '選中一個題的答案
    Windows("題庫.doc").Activate
    Call copy_t("`")
    Windows("答案B.doc").Activate
    Selection.PasteAndFormat (wdPasteDefault)
    Windows("試卷B.doc").Activate
End Sub
'===============================================================================================================================
'sele_t子程式的功能是： 從當前行開始向下選擇到標記（mark）減一行。用來選中一道試題和答案。代碼如下：
'===============================================================================================================================
Sub sele_t(mark)
    Call sele_p(mark, m)
    Selection.MoveLeft Unit:=wdCharacter, Count:=1  '游標移到上一行末
    Selection.HomeKey Unit:=wdLine
    m = m - 1
    Selection.MoveStart Unit:=wdParagraph, Count:=-m   '向上選中m-1段
End Sub
Sub sele_p(mark, m)
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
End Sub
Sub copy_t(mark)
Call sele_p(mark, m)
Selection.MoveStart Unit:=wdParagraph, Count:=-m
Selection.Copy
End Sub
Sub 刪除參數()
Call dele_c("試卷B.doc", "`")
Call dele_c("答案B.doc", "~")
Windows("試卷B.doc").Activate
End Sub
Sub dele_c(lb, mark)
Windows(lb).Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.Text = mark
fd = Selection.Find.Execute
Do While fd
   Selection.EndKey Unit:=wdLine, Extend:=wdExtend
   tt = Left(Selection.Text, 5)
   Selection.Delete Unit:=wdCharacter, Count:=1
   If tt <> "`####" Then
       Call dele_b
   End If
   fd = Selection.Find.Execute
Loop
Selection.HomeKey Unit:=wdStory
End Sub
Sub dele_b()
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
zfm = Asc(Selection.Text)
k = 0
Do While k < 5 And (zfm = 13 Or zfm = 32 Or zfm = -24159)
   Selection.Delete Unit:=wdCharacter, Count:=1
   Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
   zfm = Asc(Selection.Text)
   k = k + 1
Loop
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=" "
End Sub

’============================================================================================
‘答案B中的代碼：
thisdocument中的代碼：
Private Sub Document_Open()
Call ActivateOrOpenDocument("題庫.doc")
End Sub
Private Sub Document_Close()
Documents("答案B.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