用幻灯片做完整的“一站到底”抢答器

　　今天下午，看同事准备做一个抢答节目，名字叫“一站到底”，花了好长时间用Excel录入了近千道试题，我随口问了句：“准备怎样抢答？”，她说：“主持人拿着纸念，底下的人抢答。”“啊，这么老土的方式？现在用计算机多快？！”“那可不见得，你做一个试试？！”
　　原想很简单，结果折腾了快2个小时。
　　没有想到第二天用户又提出了新要求，比如要求界面、不同的声音、不同的试题集、处理数据录入等，只好又花了一个下午来做界面、播放声音、处理录入等。
　　完成功能：
        1、开始显示封面，点击后进入出题界面 ；
        2、先选择试题集（共3大类29集），输入后就可以出题；
        3、出题时幻灯片打出试题字幕，倒计时20秒，期间显示倒计时数和播放声音提示，最后5秒钟出现提示音，19秒出答案，如果没有成功就出现失败的声音，中间可以打断；
        4、试题内容和答案在Excel文件里，也可以随机抽题。

       显示封面：

        显示答题界面：

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long 

Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Public Const SND_ALIAS& = &H10000
Public Const SND_ASYNC& = &H1
Public Const SND_SYNC& = &H0
Public Const SND_NODEFAULT& = &H2
Public Const SND_FILENAME& = &H20000
Public Const SND_LOOP& = &H8
Public Const SND_PURGE& = &H40

Public Const sdDefault = ".Default"
Public Const sdClose = "Close"
Public Const sdEmptyRecycleBin = "EmptyRecycleBin"
Public Const sdMailBeep = "MailBeep"
Public Const sdMaximize = "Maximize"
Public Const sdMenuCommand = "MenuCommand"
Public Const sdMenuPopUp = "MenuPopup"
Public Const sdMinimize = "Minimize"
Public Const sdOpen = "Open"
Public Const sdSystemExclaimation = "SystemExclaimation"
Public Const sdSystemExit = "SystemExit"
Public Const sdSystemHand = "SystemHand"
Public Const sdSystemQuestion = "SystemQuestion"
Public Const sdSystemStart = "SystemStart"
'问题最小编号
Public Const IQuestionMinID = 3
'问题最大编号
Public Const IQuestionMaxID = 1230
'目前的编号
Public IQuestionCurrentID As Integer
'试题集的编号
Public SQuestionCollectID As String

Dim xlApp As Excel.Application
Dim LTCount As Integer
Dim SRow As String
Dim STEMP As String

Public ExcelAppSound As Excel.Application
Public TimerID As Long
Public TimesCount As Integer
Public BeStart As Boolean
Sub 选择试题()
    '新建一个Excel程序
    Set xlApp = New Excel.Application
    '定义当前题库的位置
    xlFilePath$ = ActivePresentation.Path & "\员工基本知识读本题库之一（地质）.xls"
    '后台打开Excel
    xlApp.Workbooks.Open xlFilePath, , False

    '显示试题内容
    ActivePresentation.Slides(1).Shapes("Rectangle 9").TextFrame.TextRange.Text = xlApp.Workbooks(1).Sheets(1).Cells(IQuestionCurrentID, 3)
    '清空答案
    ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = ""
    '记录答案
    ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text = xlApp.Workbooks(1).Sheets(1).Cells(IQuestionCurrentID, 4)

    '关闭打开的Excel
    xlApp.Workbooks.Close
    '清空xlApp
    Set xlApp = Nothing

    '准备定时器
    Dim time As Integer
    time = 20000  '每页时间为20秒
    timerStop  '清理定时器
    '倒计时20秒
    ActivePresentation.Slides(1).Shapes("Rectangle 16").TextFrame.TextRange.Text = "20"
    '开始计时
    TimerStart time
End Sub
Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
    '利用Excel播放语音
    'Set ExcelAppSound = New Excel.Application
End Sub
Sub 第一题()
    IQuestionCurrentID = IQuestionMinID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    选择试题
End Sub
Sub 最后一题()
    IQuestionCurrentID = IQuestionMaxID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    选择试题
End Sub
Sub 上一题()
    '获取当前的问题编号
    STEMP = ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text
    If STEMP = "" Then STEMP = "3"
    IQuestionCurrentID = Val(STEMP)
    '试题号减1
    IQuestionCurrentID = IQuestionCurrentID - 1
    If IQuestionCurrentID < IQuestionMinID Then IQuestionCurrentID = IQuestionMinID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    选择试题
End Sub
Sub 下一题()
    '获取当前的问题编号
    STEMP = ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text
    If STEMP = "" Then STEMP = "3"
    IQuestionCurrentID = Val(STEMP)
    '试题号加1
    IQuestionCurrentID = IQuestionCurrentID + 1
    If IQuestionCurrentID > IQuestionMaxID Then IQuestionCurrentID = IQuestionMaxID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    选择试题
End Sub
Sub 中间出结果()
    '停止计时器
    TimerID = KillTimer(0, TimerID)
    BeStart = False
    '停止播放声音
    Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
    '显示答案
    ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text
End Sub

Sub OnSlideShowTerminate()
    '幻灯片结束事件处理
    'Set ExcelAppSound = Nothing
    '如果计时器仍然在运行，需要结束
    TimerID = KillTimer(0, TimerID)
End Sub

Sub TimerStart(ByVal time As Integer)
    TimesCount = time / 1000
    TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
    BeStart = True
End Sub
Sub timerStop()
    If BeStart = False Then
        Exit Sub
    End If
    '停止计时
    TimesCount = 0
    TimerID = KillTimer(0, TimerID)
    BeStart = False
 End Sub

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    '显示时间秒数
    TimesCount = TimesCount - 1
    ActivePresentation.Slides(1).Shapes("Rectangle 16").TextFrame.TextRange.Text = TimesCount
    '最后1秒显示答案
    If TimesCount = 1 Then
       ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text
    End If

    '倒数5秒的处理
    If TimesCount <= 5 Then
        '停止声音
        Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
        '如果需要可以播放语音念数字5、4、3、2、1
        'ExcelAppSound.Speech.Speak Str(TimesCount)
        '播放最后倒计时声音
        Call PlaySound(ActivePresentation.Path & "\提醒.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
        '停止计时器
        If (TimesCount <= 0) Then
            Call PlaySound(ActivePresentation.Path & "\时间到.wav", 0&, SND_ASYNC Or SND_NODEFAULT) '如果时间长可以加SND_LOOP避免反复调用
            TimerID = KillTimer(0, TimerID)
        End If
    Else
        Call PlaySound(ActivePresentation.Path & "\计时.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
    End If
    If Not BeStart Then
        TimerID = KillTimer(0, TimerID)
    End If
End Sub

Sub 选择试题集()
    Load UserForm1
    UserForm1.Show
    ActivePresentation.Slides(1).Shapes("Rectangle 19").TextFrame.TextRange.Text = SQuestionCollectID
End Sub

Sub 隐藏和显示封面()
    ActivePresentation.Slides(1).Shapes("Rectangle 20").Visible = Not ActivePresentation.Slides(1).Shapes("Rectangle 20").Visible
End Sub