人人都能写的基于PPT的抽奖程序 篇一：年会抽奖有黑幕？用PowerPoint自己写一个抽奖程序吧

背景

临近农历新年，相信各家公司都会有一个保留项目——年会，而在年会的各个环节之中，最让大家期待的莫过于抽奖环节。群里昨天还看到有人说，某司的“阳光普照奖”是iPhone X，这让我们这种最高奖项都达不到iPhone X标准的情何以堪呢……

言归正传，不知道各位值友所在的公司是由谁来负责写这个抽奖程序的，从没中过奖的你是否曾怀疑抽奖程序里面有什么黑幕？每次拿“阳光普照奖”之后是否有把抽奖程序源代码拿来review一下的冲动？如果你曾有过类似的想法，那么恭喜你——在这篇原创中，我会介绍一个基于大家非常熟悉的PPT幻灯片的抽奖程序，代码简单可读绝对没有黑幕。总得来说，这样一个PPT抽奖程序有以下优点：

1. 使用VBA脚本语言，解释执行、无需编译，黑幕无处遁形

2. 对运行环境较少的依赖性，不需要.NET xxx之类的玩意
   

3. 抽奖名单存放在独立的文本文件中，可读性、可维护性佳

4. PPT页面可以使用各种图片素材任意美化，告别古板的Windows框架程序

5. 极强的灵活性，奖项的修改分分钟搞定

基于以上原因，我司最近几年的抽奖程序都是由我来亲自操刀，比如下面的视频展示了我司今年年会奖将会使用的抽奖程序（当然Logo之类的已隐去，名单也是用的上海分剁某次线下活动的值友群昵称）。

关于这个视频，有以下几点需要说明一下：

1. 录制对象是运行在Mac OS上的Windows虚拟机，分辨率设置为640x480，所以可能画面较小，实际使用中可以使用任意分辨率、任意长宽比

2. 正因为虚拟机的原因，中间可能会看到一些卡顿，实际运行在任何不是古董级的电脑上都非常流畅

3. 名单滚动/显示框的字体和大小是可以任意设置的，视频中有些名字显示不全的情况，是因为群昵称太长，实际抽奖名字一般都不会这么长
   

然后我们可以看到这个抽奖PPT除了最基本的“抽奖”以外，还实现了如下功能：

每抽出一个奖项之后有5秒的按钮冻结时间，防止意外触发下一次抽奖
可以一次抽取多个名单（比如四等奖一次抽5名）也可以一次抽取一个名单
对于不在现场的中奖者，还可以点击“缺席”按钮重新抽取，满足“中奖者必须在现场”这种使用场景
所有中奖记录（包括缺席的中奖名单）都实时记录在一个单独的文本文件中，方便后续查看
页面提供了一个小的“日志”框，方便回看历史中奖者
缺席的中奖者在点击了“缺席”按钮之后会从日志框内消失
既可以抽取互斥奖项，也可以抽取不互斥奖项（四、三、二、一等奖之间互斥，但跟幸运奖不互斥）
不互斥奖项可以满足抽取“熬夜奖”等特殊场景（即中过前面的奖项也可以再中“熬夜奖”）

基本上我司近几年的年会抽奖环节中所提出的需求，都被上述视频中的PPT抽奖程序覆盖了。当然这已经是一个经过几年不断修改和完善的版本。在这篇原创中，我会给大家介绍一个单页但覆盖以上80%功能的PPT抽奖程序，有PPT制作经验的读者应该可以在1小时内做出一个可以用作年会抽奖的PPT。下面的视频是最终效果——

想要做出上面这个视频中这样的抽奖PPT并能正常运行，有一些基本的条件需要满足：

* Windows操作系统（Mac OS上的Office不支持ActiveX）
* Microsoft Power Point（没有试过所有版本，但2003、2007、2010或更新版本应该都可以）
* 如果要在非中文的操作系统显示中文，需要在区域和语言设置中修改非Unicode程序语言为中文
* 最后当然要启用“宏”

这些条件应该很容易满足吧，你手上的任何一台电脑基本上都满足以上条件。那么我们就正式开始吧。

添加页面控件

以下所有的截图，基于值得买原创文章对图片最大宽度600像素的限制，依旧使用640x480像素的虚拟机进行演示。640x480像素大概是长这样的……稍微有点奇怪 。这里使用的是Office 2007专业版，虚拟机上我就装了PPT，没装其它组件。

首先新建一个PPT幻灯片，选择任意一个模板。美化部分就不介绍了，抽奖功能做好以后可以自己随意发挥。

然后把默认关闭的“开发工具”菜单打开。方便后续添加控制以及编辑VBA代码。

在添加控件之前，我们先来看一下前面视频中的那个页面有哪些控制。首先是两个文本框，分别是用来显示滚动名单的TextBox1和用来显示抽奖历史的TextBox2；然后是三个按钮，分别是“开始”CommandButton1、“缺席”CommandButton2和“重置”CommandButton3；最后还有一个下拉框ComboBox1。添加控件的时候要注意一下顺序，因为默认该页面添加的第一个TextBox会被命名为TextBox1，第二个则是TextBox2，这些名称跟后面的VBA代码有关联，所以不能弄错顺序。

从“开发工具”菜单上面依次添加2个文本框，3个按钮和1个下拉框。调整一下尺寸和位置，得到下图的样子。

然后把3个按钮上面的文字分别设置成“开始”、“缺席”和“重置”。双击任意按钮打开VBA窗口，左边可以看到这个按钮的属性，它的名称是“CommandButton1”，通过修改Caption属性把按钮文字改成“开始”，再通过修改Font属性适当调整一下字体。另外两个按钮也同样操作。

接下来我们再把下拉框和两个文本框的属性稍微修改一下，这些属性后期也可以随时根据需要调整。先把下拉框的字体设置成“微软雅黑”，然后把两个文本框的字体也同样设置一下，同时修改两个文本框的MultiLine属性为True，这样里面的文字就可以换行。而上方那个文本框因为要显示滚动名单，字号可以设置大一些。

添加控件响应代码

在给这些控制修改属性的时候，其实右侧已经自动生成了一些空的代码块。需要注意的是修改这些代码的时候要确认当前的代码是属于哪一页幻灯片，这在多页幻灯片的抽奖程序中尤其重要。下图中的代码属于Slide1。

把右侧的代码全选并删除，粘贴入以下代码。

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("5,3,1,10", ",", -1, vbTextCompare)
arrNumPrize = NumArray(arrNumPrize_)
arrCurrentNum_ = Split("0,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”，然后点击确定。

接下来可以把这个新建的演示文稿保存一下，注意保存的时候选择格式为“PowerPoint 97-2003 演示文稿”，否则不能保存宏代码。此处把它命名为“抽奖程序.ppt”并保存在桌面。

调整奖项

前面提到过，基于PPT的抽奖程序修改奖项非常方便，这里介绍一下修改奖项的方法。重新打开VBA窗口（任何时候用Alt + F11可以打开VBA窗口），双击左边的Slide1，定位到Sub InitComboBox1()。这里有3段代码中的3个字串需要修改。这3个字串分别是以下截屏中高亮显示的“三等奖,二等奖,一等奖,幸运奖”、“5,3,1,10”和“0,0,0,0”。需要注意两点，一是字串前后的引号都是半角符号，二是字串中间的分隔逗号也是半角符号。再看字串的意义——前两个字串组合起来表示奖项名称和每个奖项的抽取个数，而第3个字串只要简单地理解为把第2个字串中的数字全部替换成0。换句话说，上述3个字串表示抽取5个三等奖、3个二等奖、1个一等奖和10个幸运奖。特别提醒，字串经逗号分隔后的个数必须保持一致。你可以随意增加奖项个数，比如下面这3个新字串的组合，在前述奖项的基础上增加了20个五等奖和10个四等奖。

五等奖,四等奖,三等奖,二等奖,一等奖,幸运奖
20,10,5,3,1,10
0,0,0,0,0,0

调整奖项之后记得保存PPT。

添加抽奖名单

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

见证奇迹的时刻

接下来就是见证奇迹的时刻了——如果你前面的这些步骤都正确完成了，那么这个抽奖程序应该能够正确运行了。进入幻灯片放映模式，从下接框选择一个奖项，点击“开始”按钮抽奖吧。

抽出任何一个奖项都会被保存到PPT同目录下的一个文本文件“Lottery.log”中，抽奖中或者抽奖结束后都可以通过查看这个文件来翻阅抽奖结果。缺席的中奖者会由“DELETE”标记出。

后续优化及注意事项

可以看到上述从无到有创建的PPT已经具备了示例中单页抽奖程序的全部功能，当然美观度还差一些。通过调节这些控制的属性，比如文本对齐方式为“居中”，比如字体再调大一点，比如把TextBox2的ScollBar属性改成2，这样里面文字超出文本框高度的时候会出现滑块。

剩下的就是PPT模板的美化了，这些跟VBA、控件都无关，怎么好看怎么来就行了。

中途关闭了PPT怎么办

正常情况下，为了保证“互斥”，抽奖结束之前是不能关闭PPT的，但如果不小心关了，可以用以下两种办法来“曲线救国”：一种办法是把已中奖的名字从namelist.txt的名单里面删除，另一种办法是在名单里已中奖名字的后面加上一个星号“*”，名字末尾是星号“*”的在抽奖时会被忽略。

不希望奖项互斥怎么办

基于上面的那个结论，如果希望奖项不互斥（中过前面的奖项还可以继续中后面的奖项），只要在抽完一个奖项之后，关闭PPT再重新打开，接着继续抽下一个奖项即可。

缺席按钮怎么用

如果你们在抽奖的时候规定只有在现场的人才能中奖，那么当抽到一个不在现场的名字时，只要点一下“缺席”按钮，就可以忽略前面这个缺席者继续抽取下一个人，而且这个缺席者在整个抽奖过程中将不会再被抽中（相当于已中奖并触发了互斥）。

重置按钮怎么用

重置按钮用于在抽奖开始前进行试抽奖之后，清空所有内存中的抽奖记录，用于正式开始抽奖。它的效果跟关闭PPT之后再打开差不多。另一个用途是，当抽奖过程中不小心保存了PPT，那么下次再打开PPT就会出现中奖名字直接显示在文本框中的情况，这个时候用“重置”按钮可以恢复到未抽奖的状态并清空所有文本框。

如果怕有人在抽奖过程中误触发“重置”，其实也可以把它的Visible属性设置成False，然后再把PPT设置成“只读”属性，这样就能有效避免上述“抽奖过程中不小心保存了PPT”的情况。换句话说，抽奖PPT只要设置好了，每次抽奖都应该以“只读”模式打开，而不应该在抽奖过程中或结束后保存对PPT的更改——所有的抽奖结果在Lottery.log里面都已经自动保存了。

预告

作为这一系列的后续，目前想到的有两篇原创可以有空补上。

篇二：对上述VBA代码进行分段解释，让大家可以理解抽奖程序的运作原理

第三：在理解了VBA代码的前题下，修改“篇一”的成果，使之成为本文开头的具有更复杂功能的抽奖程序

有兴趣的话不妨收藏一下，实践过程中碰到什么问题都可以在评论区提出。