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

　　这是我在《电脑编程技巧与维护》上发表的第七篇文章〖２０１４年１月上半期〗，这篇文章的发表给了我压力，因为文章写得急，没有达到我认为好的程度，所以担心不能发表。很感动、也很感谢，这激励我往后一定要写出有质量、好的技术文章。

　　摘　要：本文详细论述了在幻灯片中运用VBA进行轻量级应用程序开发的方法和技巧。
　　关键词：幻灯片  VBA
　　在企事业单位上我们经常能见到一些知识抢答赛之类的应用，对于这一类的程序，通常我们首先想到的就是用快速开发工具来做，如C#、VB.net等，但是用户对界面和功能的不断变化让开发人员比较纠结。我在熟悉幻灯片和VBA后对于类似的应用直接就用幻灯片来开发，而且对于这类轻量级的开发明显达到了高效、快捷、用户满意度提升的效果。
　　应用幻灯片开发这类应用的优势明显。首先是简捷，不需要安装其他多余附件和制作安装程序；其次，界面随需而变，应用程序的用户友好基础极其重要的一点就是界面，在幻灯片的开发过程中，界面可以随时增减、替换而不需要更改代码，这是很大的一个优势，另外，目前推行的多层开发模式在幻灯片的应用开发中也可以得到很好的体现。

　　上图即是在幻灯片中应用VBA进行开发的一般模式，接到用户需求进行分析后就可以快速地进行原型开发。即：
　　1、 分析用户需求；
　　2、 根据需求制作用户界面并与用户进行互动直到界面完全体现用户需求；
　　3、 细分功能并开发自定义模块（过程或者函数）；
　　4、 按照用户控制进行功能的进一步组装，即完善控制部分；
　　5、 将界面部分与控制部分继续绑定。
　　下面将一个知识抢答赛上的抢答器作为示例进行讲解。
　　知识抢答赛分第一轮、第二轮、决赛，每一轮对界面和功能有不同的要求，如第一轮比赛的界面如下：
　　要求如下：
　　1、 每个队答题总时长为3分钟，需要显示倒计时；
　　2、 每道试题的抢答时长为20秒，需要倒计时，在20秒钟内需要有秒表的走动音，最后5秒进入提示音【可以语音提示5、4、3、2、1】；
　　3、 每队有三次“过”（即放弃答题、按错误处理）的机会，用黄灯泡显示，超过3次即不可再运用“过”的权利；
　　4、 需要实时套题和试题号、答对和答错的题目数；
　　5、 在答对、放弃答题、每道试题计时器到达0秒的情况下显示答案。
　　本次抢答赛应用的数据来自于Excel文件，当然也可以换成数据库。
　　具体的程序代码如下（详细见注释）：

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

　　显示封面： 

　　显示答题界面：

 

完整程序：

'播放MP3声明
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'使用定时器声明
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 = 1
'问题最大编号
Public Const IQuestionMaxID = 230
'目前的编号
Public IQuestionCurrentID As Integer
'试题集的编号
Public SQuestionCollectID As String
'存储试题的数组
Dim SST(IQuestionMaxID, 2) As String
'对的按钮
Dim ButtonRight As Boolean
'错的按钮
Dim ButtonMistake As Boolean

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

'是否开始3分钟计时
Dim JS3FZ As Boolean
Public Timer3ID As Long
Public Times3Count As Integer

Public ExcelAppSound As Excel.Application
Public TimerID As Long
Public TimesCount As Integer
Public BeStart As Boolean

Sub 选择试题()
   
    '准备20秒的定时器
    Dim time As Integer
   
    time = 20000  '每页时间为20秒
    timerStop  '清理定时器
   
    '倒计时20秒
    ActivePresentation.Slides(1).Shapes("Rectangle 16").TextFrame.TextRange.Text = "20"
    'IQuestionCurrentID = IQuestionCurrentID + 1
    '显示试题内容
    ActivePresentation.Slides(1).Shapes("Rectangle 9").TextFrame.TextRange.Text = SST(IQuestionCurrentID, 1)
    '清空答案
    ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = ""
   
    '开始每道小题的计时
    TimerStart time
   
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 上一题()
    '试题号减1
    IQuestionCurrentID = IQuestionCurrentID - 1
    If IQuestionCurrentID < IQuestionMinID Then IQuestionCurrentID = IQuestionMinID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    选择试题
End Sub
Sub 下一题()
    '试题号加1
    IQuestionCurrentID = IQuestionCurrentID + 1
    选择试题
    If IQuestionCurrentID > IQuestionMaxID Then IQuestionCurrentID = IQuestionMaxID
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
End Sub
Sub 重播当前试题()
    选择试题
    '写回
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = Str(IQuestionCurrentID)
    '停止播放声音
    Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
    Call PlaySound(ActivePresentation.Path & "\选题.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
End Sub

Sub 中间出结果()
    If ButtonRight Then
        '停止计时器
        TimerID = KillTimer(0, TimerID)
        BeStart = False
        '停止播放声音
        Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
        Call PlaySound(ActivePresentation.Path & "\加分.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
        '显示答案
        ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = SST(IQuestionCurrentID, 2)
    End If
End Sub
Sub 过()
    If ButtonMistake Then
        '停止计时器
        TimerID = KillTimer(0, TimerID)
        BeStart = False
        '停止播放声音
        Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
        Call PlaySound(ActivePresentation.Path & "\抢答违例.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
        '显示答案
        ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = SST(IQuestionCurrentID, 2)
    End If
End Sub
Sub OnSlideShowTerminate()
    '幻灯片结束事件处理
    '如果计时器仍然在运行，需要结束
    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 = 0 Then
       ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = SST(IQuestionCurrentID, 2)
    End If
   
    '倒数5秒的处理
    If TimesCount <= 5 Then
        '停止声音
        Call PlaySound(vbNullString, 0&, SND_NODEFAULT)
        '播放最后倒计时声音
        Call PlaySound(ActivePresentation.Path & "\抢答违例.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
        '停止计时器
        If (TimesCount <= 0) Then
            ButtonRight = False
            ButtonMistake = False
       
            Call PlaySound(ActivePresentation.Path & "\时间到.wav", 0&, SND_ASYNC Or SND_NODEFAULT)
            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 选择试题集()
    JS3FZ = False
    Load UserForm1
    UserForm1.Show
    ActivePresentation.Slides(1).Shapes("Rectangle 19").TextFrame.TextRange.Text = SQuestionCollectID
   
    ''''读入试题内容和答案'''''
    '新建一个Excel程序
    Set xlApp = New Excel.Application
    '定义当前题库的位置
    xlfilepath$ = ActivePresentation.Path & "\" & Trim(Str(SQuestionCollectID)) & ".xls"
    '后台打开Excel
    xlApp.Workbooks.Open xlfilepath, , False
    For IFOR = 1 To IQuestionMaxID
        SST(IFOR, 1) = xlApp.Workbooks(1).Sheets(1).Cells(IFOR, 1)
        SST(IFOR, 2) = xlApp.Workbooks(1).Sheets(1).Cells(IFOR, 2)
    Next
    '关闭打开的Excel
    xlApp.Workbooks.Close
    '清空xlApp
    Set xlApp = Nothing
    IQuestionCurrentID = 0
    '显示初始画面
    '首页消失
    ActivePresentation.Slides(1).Shapes("Rectangle 20").Visible = Not ActivePresentation.Slides(1).Shapes("Rectangle 20").Visible
    '3分钟倒计时清空
    ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text = ""
    '20秒倒计时清空
    ActivePresentation.Slides(1).Shapes("Rectangle 16").TextFrame.TextRange.Text = ""
    '试题清空
    ActivePresentation.Slides(1).Shapes("Rectangle 9").TextFrame.TextRange.Text = ""
    '答案清空
    ActivePresentation.Slides(1).Shapes("Rectangle 10").TextFrame.TextRange.Text = ""
    '试题号清空
    ActivePresentation.Slides(1).Shapes("Rectangle 12").TextFrame.TextRange.Text = ""
End Sub

Sub 显示封面()
    ActivePresentation.Slides(1).Shapes("Rectangle 20").Visible = True
End Sub
Sub 继续()
   
End Sub

Sub Timer3Stop()
    If JS3FZ = False Then
        Exit Sub
    End If
    '停止计时
    TimesCount = 0
    Timer3ID = KillTimer(0, Timer3ID)
    JS3FZ = False
 End Sub

Sub Timer3Proc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    '显示时间秒数
    Times3Count = Times3Count - 1
    ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text = Times3Count
    '最后1秒显示答案
    If Times3Count = 0 Then
       '时间到
       ActivePresentation.Slides(1).Shapes("Rectangle 18").TextFrame.TextRange.Text = "时间到"
       '20秒倒计时停止
       timerStop
       '3分钟倒计时停止
       Call PlaySound(ActivePresentation.Path & "\时间到.wav", 0&, SND_ASYNC Or SND_NODEFAULT) '如果时间长可以加SND_LOOP避免反复调用
       Timer3Stop
       Exit Sub
    End If
   
    If Not JS3FZ Then
        Timer3ID = KillTimer(0, Timer3ID)
    End If
End Sub

Private Function ConvShortFilename(ByVal strLongPath$) As String
    Dim strShortPath$
    If InStr(1, strLongPath, " ") Then
        strShortPath = String(LenB(strLongPath), Chr(0))
        GetShortPathName strLongPath, strShortPath, Len(strShortPath)
        ConvShortFilename = Left(strShortPath, InStr(1, strShortPath, Chr(0)) - 1)
    Else
        ConvShortFilename = strLongPath
    End If
End Function

Public Sub MMPlay(ByRef FileName As String)
    FileName = ConvShortFilename(FileName)
    mciSendString "close " & FileName, vbNullString, 0, 0
    mciSendString "open " & FileName, vbNullString, 0, 0
    mciSendString "play " & FileName, vbNullString, 0, 0
End Sub

Public Sub MMStop(ByRef FileName As String)
    FileName = ConvShortFilename(FileName)
    mciSendString "stop " & FileName, vbNullString, 0, 0
    mciSendString "close " & FileName, vbNullString, 0, 0
End Sub

Sub MinePlay()
    '播放MP3音乐
    MMPlay (ActivePresentation.Path & "\主题.MP3")
End Sub