使用VBA脚本在ppt里实现效果比较成熟的抽奖系统

概述

这个博客主要记录了使用VBA在ppt里制作较精美的抽奖系统的过程
（注：这个方法仅在Windows操作系统可以实现）
（另注：只有Microsoft Office的ppt（没有x）可以实现）

过程

添加页面控件

在Microsoft office里找，打开默认关闭的“开发工具”
然后根据自己的需求把ppt的第一页做成自己想要的样子
我这里添加了：
首先是两个文本框，分别是用来显示滚动名单的TextBox1和用来显示抽奖历史的TextBox2；然后是三个按钮，分别是“开始”CommandButton1、“重复”CommandButton2和“重置”CommandButton3；最后还有一个下拉框ComboBox1。添加控件的时候要注意一下顺序，因为默认该页面添加的第一个TextBox会被命名为TextBox1，第二个则是TextBox2，这些名称跟后面的VBA代码有关联，所以不能弄错顺序。
然后把3个按钮上面的文字分别设置成“开始”、“重复”和“重置”。双击任意按钮打开VBA窗口，左边可以看到这个按钮的属性，它的名称是“CommandButton1”，通过修改Caption属性把按钮文字改成“开始”，再通过修改Font属性适当调整一下字体。另外两个按钮也同样操作。
最后再进行适当的美化，结束后效果大致如下：

添加控件响应代码

双击任何一个按钮，把出现的页面里的内容全部删除，然后粘贴入以下代码：

Dim blnPauseClicked As Boolean
Dim strCatched As String
Dim arrNumPrize() As Integer
Dim arrNumPrize_() As String
Dim arrCurrentNum() As Integer
Dim arrCurrentNum_() As String
Dim strCurrentCatched As String
Private Sub ComboBox1_Change()
    If ComboBox1.ListIndex >= 0 And arrNumPrize(ComboBox1.ListIndex) > arrCurrentNum(ComboBox1.ListIndex) Then
        CommandButton1.Enabled = True
    Else
        CommandButton1.Enabled = False
    End If
    Do Until blnPauseClicked
        ToggleCommandButton1
    Loop
    CommandButton2.Enabled = False
End Sub
Private Sub ComboBox1_DropButtonClick()
    On Error Resume Next
    t = UBound(arrNumPrize)
    If Err.Number <> 0 Then
        InitComboBox1
        Err.Clear
    End If
    On Error GoTo 0
End Sub
Private Sub CommandButton1_Click()
    On Error Resume Next
    t = UBound(arrNumPrize)
    If Err.Number <> 0 Then
        InitComboBox1
        Err.Clear
    End If
    On Error GoTo 0
    ToggleCommandButton1
    If CommandButton1.Caption = "停止" Then
        LoopString
    Else
        Do Until InStr(1, strCatched, TextBox1.Text, vbTextCompare) = 0
            TextBox1.Value = GetRandomString()
            DoEvents
        Loop
        RemoveName
        strCurrentCatched = TextBox1.Value
        strCatched = strCatched & TextBox1.Value
        arrCurrentNum(ComboBox1.ListIndex) = arrCurrentNum(ComboBox1.ListIndex) + 1
        If arrCurrentNum(ComboBox1.ListIndex) - arrNumPrize(ComboBox1.ListIndex) >= 0 Then
            CommandButton1.Enabled = False
        End If
        AddTextBox2 ComboBox1.Value & ": " & TextBox1.Value & " (" & _
            arrCurrentNum(ComboBox1.ListIndex) & " of " & arrNumPrize(ComboBox1.ListIndex) & ")"
        AddLog ComboBox1.Value & ": " & TextBox1.Value
    End If
End Sub
Sub ToggleCommandButton1()
    If CommandButton1.Caption = "开始" Then
        CommandButton1.Caption = "停止"
        CommandButton1.ForeColor = vbRed
        blnPauseClicked = False
        CommandButton2.Enabled = False
    Else
        CommandButton1.Caption = "开始"
        CommandButton1.ForeColor = vbBlue
        blnPauseClicked = True
        CommandButton2.Enabled = True
    End If
End Sub
Sub LoopString()
    Do While True
        TextBox1.Value = GetRandomString()
        DoEvents
        If blnPauseClicked Then
            Exit Do
        End If
    Loop
End Sub
Sub ResetAll()
    Do Until blnPauseClicked
        ToggleCommandButton1
    Loop
    TextBox1.Value = ""
    TextBox2.Value = ""
    RefreshDic
    InitComboBox1
    ComboBox1.ListIndex = 0
    CommandButton1.Enabled = True
    CommandButton2.Enabled = False
    strCatched = ""
    strCurrentCatched = ""
End Sub
Private Sub CommandButton2_Click()
    RemoveTextBox2
    RemoveLog strCurrentCatched
    RemoveName
    ToggleCommandButton1
    arrCurrentNum(ComboBox1.ListIndex) = arrCurrentNum(ComboBox1.ListIndex) - 1
    If arrCurrentNum(ComboBox1.ListIndex) - arrNumPrize(ComboBox1.ListIndex) < 0 Then
        CommandButton1.Enabled = True
    End If
    If CommandButton1.Caption = "停止" Then
        LoopString
    End If
End Sub
Private Sub CommandButton3_Click()
    ResetAll
End Sub
Sub InitComboBox1()
    RefreshDic
    ComboBox1.List = Split("红方,蓝方,党办锦鲤", ",", -1, vbTextCompare)
    arrNumPrize_ = Split("1,1,1", ",", -1, vbTextCompare)
    arrNumPrize = NumArray(arrNumPrize_)
    arrCurrentNum_ = Split("0,0,0", ",", -1, vbTextCompare)
    arrCurrentNum = NumArray(arrCurrentNum_)
    If ComboBox1.ListIndex < 0 Then
        ComboBox1.ListIndex = 0
    End If
End Sub
Sub AddTextBox2(str)
    If TextBox2.Value = "" Then
        TextBox2.Value = Replace(str, vbCrLf, ", ")
    Else
        TextBox2.Value = Replace(str, vbCrLf, ", ") & vbCrLf & TextBox2.Value
    End If
End Sub
Sub RemoveTextBox2()
    If InStrRev(TextBox2.Value, vbCrLf, -1, vbTextCompare) = 0 Then
        TextBox2.Value = ""
    Else
        TextBox2.Value = Right(TextBox2.Value, Len(TextBox2.Value) - InStr(1, TextBox2.Value, vbCrLf, vbTextCompare) - 1)
    End If
End Sub

然后在VBA窗口中右击左侧的“VBAProject（演示文稿1）”，依次选择**“插入”、“模块”**。
在右侧的代码窗口粘贴入以下代码。

Dim strOutput As String
Dim objFSO As Scripting.FileSystemObject
Dim objOutput As TextStream
Dim objDic As Dictionary
Dim arrIndex() As String

Sub AddLog(str)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strOutput = Replace(ActivePresentation.FullName, ActivePresentation.Name, "Lottery.log")
    Set objOutput = objFSO.OpenTextFile(strOutput, ForAppending, True)
    objOutput.WriteLine Now & " | " & str
    objOutput.Close
    Set objOutput = Nothing
    Set objFSO = Nothing
End Sub
Sub RemoveLog(str)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strOutput = Replace(ActivePresentation.FullName, ActivePresentation.Name, "Lottery.log")
    Set objOutput = objFSO.OpenTextFile(strOutput, ForAppending, True)
    objOutput.WriteLine Now & " | DELETE: " & str
    objOutput.Close
    Set objOutput = Nothing
    Set objFSO = Nothing
End Sub
Sub ReadNameList(Optional str As String)
    If Not objDic Is Nothing Then Exit Sub
    Set objDic = CreateObject("Scripting.Dictionary")
    iKey = 1
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(str) Then
        sFileName = str
    ElseIf objFSO.FileExists(Replace(ActivePresentation.FullName, ActivePresentation.Name, str)) Then
        sFileName = Replace(ActivePresentation.FullName, ActivePresentation.Name, str)
    Else
        sFileName = Replace(ActivePresentation.FullName, ActivePresentation.Name, "namelist.txt")
    End If
    If Not objFSO.FileExists(sFileName) Then
        MsgBox ("Cannot find the name list file.")
        Application.Quit
    End If
    Set objNameList = objFSO.OpenTextFile(sFileName)
    Do While objNameList.AtEndOfStream <> True
        objDic.Add iKey, Replace(objNameList.ReadLine, vbTab, " ")
        iKey = iKey + 1
    Loop
    objNameList.Close
    Set objNameList = Nothing
    Set objFSO = Nothing
End Sub
Function GetRandomString(Optional iNum As Integer = 1)
    sTmp = ""
    sIndex = ""
    For i = 1 To iNum
        Do
            Randomize
            iIndex = Int((objDic.Count) * Rnd + 1)
            If objDic.Exists(iIndex) Then
                sName = objDic.Item(iIndex)
            Else
                sName = ""
            End If
        Loop Until sName <> "" And InStr(1, sTmp, sName, vbTextCompare) = 0 And Right(sName, 1) <> "*"
        If sTmp = "" Then
            sTmp = sName
            sIndex = iIndex
        Else
            sTmp = sTmp & ", " & sName
            sIndex = sIndex & "," & iIndex
        End If
    Next
    arrIndex = Split(sIndex, ",")
    GetRandomString = sTmp
End Function
Sub RemoveName()
    For i = 0 To UBound(arrIndex)
        If objDic.Exists(CInt(arrIndex(i))) Then
            objDic.Item(CInt(arrIndex(i))) = objDic.Item(CInt(arrIndex(i))) & "*"
        End If
    Next
End Sub
Sub RefreshDic()
    Set objDic = Nothing
    ReadNameList
End Sub
Function NumArray(arr() As String)
    Dim res() As Integer
    ReDim res(UBound(arr))
    For i = 0 To UBound(arr)
        If IsNumeric(arr(i)) Then
            res(i) = CInt(arr(i))
        End If
    Next
    NumArray = res
End Function

添加引用项

最后还要添加一个引用项，点击VBA窗口的菜单“工具”，并选择“引用”，勾选“Microsoft Scripting Runtime”，然后点击确定。

调整奖项

重新打开VBA窗口（任何时候用Alt + F11可以打开VBA窗口），双击左边的Slide1，定位到Sub InitComboBox1()。找到如下代码：

Sub InitComboBox1()
    RefreshDic
    ComboBox1.List = Split("红方,蓝方,党办锦鲤", ",", -1, vbTextCompare)
    arrNumPrize_ = Split("1,1,1", ",", -1, vbTextCompare)
    arrNumPrize = NumArray(arrNumPrize_)
    arrCurrentNum_ = Split("0,0,0", ",", -1, vbTextCompare)
    arrCurrentNum = NumArray(arrCurrentNum_)
    If ComboBox1.ListIndex < 0 Then
        ComboBox1.ListIndex = 0
    End If
End Sub

在第三行中修改奖项名称，在第4行中修改相应的奖项数量

添加抽奖名单

在这个ppt的同目录下，新建一个文本文档并命名为“namelist.txt”，打开这个文本文档，把抽奖名单输入到这个文本文档里面。每行一个名字，然后保存、关闭文本文档。

然后就可以使用了！

_(:з」∠)(:з」∠)(:з」∠)(:з」∠)(:з」∠)