人人都能写的基于PPT的抽奖程序 篇二：#剁主计划-上海#详解抽奖程序中VBA代码的工作原理

背景

在本系列文章的前一篇，我给大家介绍了一下如何用Microsoft PowerPoint做一个年会抽奖程序。在评论区有很多值友通过亲自实践也成功地做出了这样一个PPT，让我倍感欣慰。

人人都能写的基于PPT的抽奖程序 篇一：年会抽奖有黑幕？用PowerPoint自己写一个抽奖程序吧背景临近农历新年，相信各家公司都会有一个保留项目——年会，而在年会的各个环节之中，最让大家期待的莫过于抽奖环节。群里昨天还看到有人说，某司的“阳光普照奖”是iPhoneX，这让我们这种最高奖项都达不到iPhoneX标准的情何以堪呢……言归正传，不知道各位值友所在的公司是由谁来负责写这个抽奖程序的，从fenado| 赞224 评论142 收藏920查看详情

而在上文的末尾，我也预告了会在本系列原创的第二篇中对这个PPT里面涉及到的VBA代码进行分段解释。理解了这些代码的意义和作用，修改起来才能更加得心应手。

这里我们还是以上一篇原创中从零开始创建的那个PPT为例子。

首先我们来看上一篇中整体复制的两段代码中的第一段代码，也就是幻灯片Slide1的代码。这段代码的主要作用是跟页面上的控件进行交互，为方便分段解释，先把这段代码划分如下。

分段解析一

A

这段代码主要是变量的声明，首先定义了一个布尔型的blnPauseClicked用于标记当前“开始”按钮的状态。按钮上的文字显示“开始”的时候该变量的值是false，显示“暂停”的时候该变量的值是true。接着定义一个字符串strCatched用以记录所有获奖的名单，后面会看到名字之间是以逗号分隔的，而另一个字符串变量strCurrentCatched则用以记录最后一次抽中的名单。然后定义了一堆数组，arrNumPrize()用以存储每个奖项的数量，arrCurrentNum()用以存储每个奖项当前已抽取的数量。而另外两个对应的字符串数组arrNumPrize_()和arrCurrentNum_()，是以字符串（而不是数字）存储的变量，想来应该是可以精简掉的。

Dim blnPauseClicked As BooleanDim strCatched As StringDim arrNumPrize() As IntegerDim arrNumPrize_() As String
Dim arrCurrentNum() As Integer
Dim arrCurrentNum_() As String
Dim strCurrentCatched As String

B

第一段代码是响应ComboBox1_Change这个事件的，也就是当用户点击那个下拉框选择“一等奖”、“二等奖”或者“三等奖”的时候会触发。ComboBox1.ListIndex是下拉框的自有属性，表示列表里面选项的个数，在下拉框还没有初始化的时候这个值是-1，所以第二行IF代码的意思是如果下拉框已初始化并且当前抽取的奖项个数大于已抽取的数量，那么就可以继续抽取下一个获奖者，因此把CommandButton1（也就是“开始”按钮）置成Enable状态，否则就把CommandButton1灰掉，也就不能再点击了。接下来调用一个循环，循环的终止条件是blnPauseClicked为true，如果它不为true，在这个循环里面不断地调用ToggleCommandButton1方法，当然其实只要调用一次就变成true了（所以好像用IF也行 ）。最后再把CommandButton2灰掉，也就是那个“缺席”按钮。

第二段代码定义了针对下拉框那个“箭头”被按下时所触发的事件ComboBox1_DropButtonClick的响应，这里首先用一组On Error Resume Next和On Error GoTo 0圈一个相对安全的范围，在这个范围里面执行代码即使出错也会继续执行下一行，如果不这样做，运行的时候就报错了。为什么要这么做呢？因为下面一行t = UBound(arrNumPrize)有可能失败，当arrNumPrize()数组还没有被初始化的时候，UBound方法获取数组上界会失败。所以下面就判断Err.Number是否为零，不为零则表示上一步执行出错了，也就是说arrNumPrize()数组需要初始化，于是调用InitComboBox1方法进行初始化。

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

C

这段代码老长了……一句话概括就是按下“开始”或“停止”按钮的时候，所有逻辑都在这里面发生。第一部分On Error Resume Next和On Error GoTo 0之间的前面解释过，放在这里是因为用户也有可能在arrNumPrize()数组还没有被初始化的时候就去按“开始”按钮。接着调用ToggleCommandButton1方法把按钮文字切换一下，详细过程后面会讲到。文字切换之后再看当前按钮显示的是“开始”还是“停止”。

如果显示“停止”，说明之前显示的是“开始”，也就是说应该滚动名单进行抽奖，等待“停止”按钮按下。此处调用一次LoopString方法。为什么只调用一次呢，名单不是应该一直滚动么？因为LoopString方法里面本身是一个无限循环——直到“停止”按钮按下。

反之如果显示“开始”，说明之间显示的是“停止”且已被按下，就得揭晓一个名单咯？这里采用一个Do Until循环，循环终止条件是InStr(1, strCatched, TextBox1.Text, vbTextCompare) = 0，翻译成人话就是在strCatched里面搜索不到TextBox1.Text，再直白地讲，就是说直到屏幕上滚动显示的名单不在已抽中的名单里面，这样就实现了“中过奖的人不会再次被抽中”。而在循环里面，调用GetRandomString()方法获得一个随机的名字并把它显示在TextBox1里面。接下来一行DoEvents也很重要，它的作用是把当前任务暂时挂起，让CPU有“空闲”去处理一下其它任务，比如刷新一下显示内容，这是我在用PPT做抽奖程序初期一直不能获得名单滚动效果的原因，因为CPU一直被循环占用着，没空去刷新显示，所以TextBox1里面的文本一直不动。

接下来调用一次RemoveName方法，它的作用是把当前抽中奖的名字从总名单中注释掉，详情后面会提到。接着就是做一些记录和显示工作了，把当前抽中奖的名字存储到变量strCurrentCatched里面，把当前奖项已抽取的数量加一，然后判断一下当前奖项是否抽完了（当前奖项总数减去已抽取的数量是否大于零），如果为否，表示当前奖项抽完了，则把CommandButton1“开始”按钮灰掉。

最后分别调用AddTextBox2和AddLog方法把刚刚抽取的名字显示到TextBox2里面并写到日志文件Lottery.log里面。需要提一下在VBA里面用“& _”表示这一行和下一行之间实际是同一行，不是换行，主要是为了代码的美观和可读性。而单独的“&”是用来连接字符串的。

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

D

这是一个ToggleCommandButton1方法，正如它的名称一样，就是把CommandButton1“开始”按钮的状态切换一下。如果先前它是“开始”则把它变成“停止”，字体改成红色，然后把blnPauseClicked置成false，把CommandButton2灰掉。反之如果先前它是“停止”，则把它变成“开始”，字体改成蓝色，blnPauseClicked置成true，并把CommandButton2变成可点击状态。

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

E

这个方法也相对简单，前面也提到了“LoopString方法里面本身是一个无限循环——直到“停止”按钮按下”，事实上这段代码用一句话解释也就是这样。在这个无限循环里面，每次通过调用GetRandomString()方法得到一个随机名字并把它显示在TextBox1里面。DoEvents的用法前面讲过了。循环终止的条件是blnPauseClicked为true，也就是“停止”被按下。

Sub LoopString()
Do While True
TextBox1.Value = GetRandomString()
DoEvents
If blnPauseClicked Then
Exit Do
End If
Loop
End Sub

F

这个方法也如它的名称一般直白，就是重置所有的变量、按钮状态等。一开始还是用前面介绍过的小把戏把CommandButton1变成显示“开始”的状态。然后把所有变量清空或重置，中间把调用了RefreshDic和InitComboBox1这两个方法，分别初始化了一个存储抽奖名单的字典对象和那个唯一的下拉框。

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

G

这段代码是对CommandButton2“缺席”按钮的响应，首先分别调用RemoveTextBox2和RemoveLog方法把抽中但是缺席的这个名字从TextBox2和日志文件Lottery.log里面删掉。这时候CommandButton1显示的是“开始”，所以用ToggleCommandButton1把它变成“停止”，再把当前奖项已抽取的人数减一（因为缺席释放了一个名额）。接下来两个IF语句我看得有点凌乱，因为好像条件永远是满足的，也就是说CommandButton1为被置成可点击状态，并且会执行一次LoopString。让我想想哪里出问题了，毕竟从最开始到现在这些代码改过无数遍了……

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

H

这段代码是对CommandButton3“重置”按钮的响应。一行代码，调用ResetAll方法，结束。

Private Sub CommandButton3_Click()
ResetAll
End Sub

I

这是大家需要重点理解的一段代码，因为奖项的设置就是在这里修改的。这个方法的名称表明它是用来初始化那个下拉框的。初始化第一步是调用RefreshDic方法初始化名单，然后把“三等奖,二等奖,一等奖,幸运奖”这个字符串经由Split方法变成一个字符串数组，并把它赋给ComboBox1，这样就能在点击下拉框的时候显示相应的选项了。接下来4行代码，分别把对最开始声明的4个数组进行赋值，5、3、1、10分别是上述几个奖项的名额，而0、0、0、0则是当前已抽取的个数，初始化当然都是0。这里面调用了一个NumArray()方法把字符串数组转换成数字数组。最后判断下拉框是否有选项被选中，如果没有，默认选中第一项，第一项的ListIndex属性为0。

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

具体怎么调整奖项，请参见前一篇的“调整奖项”章节。基于这种设计，理论上可以抽取任意多种奖项，每一种奖项的名额也可以任意设置。

J

这个方法从字面理解，是往TextBox2里面追加显示一个字符串，每次抽取一个新名字的时候会调用这个方法。If语句判断TextBox2文本框里当前内容是否为空，如果为空则把新字符串直接显示，如果非空，则把新字符串和现有文本用换行符连接起来，再显示在文本框中。这里还作了一个小的变换，把原本字符串中的换行符用逗号代替了，原因是有时候会同时抽取多个名额并显示在TextBox1中，这时候为了美观可能会在TextBox1中每行显示一个名字，这样传递到AddTextBox2方法的文本中有可能本身含有换行符，需要转成逗号以便在TextBox2中变成一行。

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

K

这个方法是对上述方法的逆操作，每次点击“缺席”之后需要调用这个方法把TextBox2中的最新一行删除。用一个If语句判断TextBox2中是否已有多行文本，如果为否，则删除一行后直接变成空字符串，如果为是，则找到第一个换行符并把该换行符及前面的字符全部删除（以达到删除一行的目的）。

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

分段解析二

接着来看“模块一”的代码，用模块是为了在不同的幻灯片之间共享代码和变量，这在后面制作多页幻灯片抽奖程序的时候会体会到。为方便分段，还是先标一下号。

L

模块代码的第一段依旧是变量和对象的声明。这里定义了一个字符串strOutput，一个字符串数组arrIndex()，然后三个对象——Scripting.FileSystemObject用以进行文件的访问、TextStream用以文本文件的读写、Dictionary用以存储抽奖名单。需要强调一下的是下面这个步骤不能少：点击VBA窗口的菜单“工具”，并选择“引用”，勾选“Microsoft Scripting Runtime”，然后点击确定。否则运行到这里的时候会报错。

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

M

这个方法正如它的名称一样，把给定的字符串写到日志文件Lottery.log里面。首先初始化一个objFSO对象，再用它的OpenTextFile方法把Lottery.log打开进行写操作，ForAppending参数表示在现有内容的基础上增加。Lottery.log的完整路径是通过当前PPT的完整路径来生成的。接下去就是把传入的字符串前面添加时间戳写到Lottery.log里面，然后把这个文件关掉，销毁这两个对象，结束。

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

N

这个方法跟上面那个几乎一样，唯一的区别是写入的内容多了一个“DELETE: ”标识。想来好像可以跟上面这个方法合并，通过一个参数来实现两种功能。 换句话说，当按下“缺席”按钮的时候，这个删除操作实际在日志文件中是添加了一行新内容，标记了“删除”而已。

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

O

这段代码稍微有点长，它的作用是从给定的文件文件中读取抽奖名单。这个方法接受一个可选参数str，它既可以是空值，又可以是不带路径的文件名，也可以是带完整路径的文件名。方法第一行代码先判断objDic对象是否已存在，如果存在了直接退出当前方法。如果不存在，下面接着创建了一个名为objDic的Scripting.Dictionary字典对象并初始化了一个变量iKey赋值1。

接着对可选参数str进行判断，如果存在该（完整路径）文件，或者在PPT同目录存在该（不含完整路径）文件，则使用这个参数指向的文件作为抽奖名单，如果上述两个文件都不存在，则从PPT目录下寻找“namelist.txt”作为抽奖名单。如果还是不存在，那么后面objFSO.FileExists(sFileName)就会返回false，然后就报错了——Cannot find the name list file。 随即退出程序。

如果一切正常，包含抽奖名单的文本文件存在，则用objFSO.OpenTextFile方法把它打开进行逐行读取。.ReadLine方法从文本流中读取一行，这里把可能存在的Tab替换成了空格。.AtEndOfStream为true则表示读取文本流的末尾了。因为抽奖名单是按照每行一个名字进行保存的，所以每读取出来一行就是一个名字，把该名字和一个递增的序号iKey组成字典里面的一组数据，所以名单在字典里面大概就是这种样子。

最后把文本文件关掉，把各种对象销毁。

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

P

字典准备好了，接下来就是如何从中随机抽取了。原理很简单——从1 - N这N个连续的数字中取一个随机数，这个随机数所对应的Item就是抽出来的名字。具体如何实现呢？请往下看。

这个方法接受一个可选参数iNum，如果不指定则默认使用1。也就是说这个方法本身是支持一次抽取多个获奖者的，在上一篇原创里有人问如何一次抽取5名，其实这种情况本来就在考虑范围了。来看代码，首先初始化两个字符串变量，sTmp是用来最终返回名单的，sIndex则记录了这些名单所对应的序号Key。

接下来是一个For循环，用以获得iNum个名单并返回。在For循环里面，首先是一个Do Loop循环，循环的中止条件是临时变量sName不为空、sTmp里面不包含sName以及sName的最后一个字符不为星号。第一个条件不为空很容易理解，为空当然不能停止循环；第二个条件是要保证在这一次抽取多名的名单中没有重复；第三个条件则保证了在这次抽取过程中没有先前已被抽中过的名字——也就是说先前已抽中过的名字是被标记了星号的，大概像这样。

而在Do Loop循环里面，首先调用Randomize初始化随机种子，然后用Rnd方法在1至字典序号上限Key之间生成一个随机数，该随机数对应的Item取出来赋给sName。这里的If objDic.Exists语句细看好像也不是必须的，应该是条件永远成立。

Do Loop循环之后，判断sTmp，为空则直接把sName赋给它，不为空则把sName加上逗号添加到原有字符串后面。顺便把sIndex也同样更新一下，不同的是sIndex存储的是字典里的Key也就是数字——虽然数字是以字符形式存储的。最后把sIndex转换成一个字符串数组并赋给arrIndex()，再把sTmp作为最终结果返回。arrIndex()是干嘛用的？请看下一节。

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

Q

这个方法的作用是把已中奖的名单从字典里面注释掉（这样就实现了奖项的互斥）。既然arrIndex()存储了本次抽取名单的对应Key，就可以用一个For循环对arrIndex()数组进行遍历，把arrIndex()里面包含的那些Key所对应的Item都注释掉，注释的方法是在原内容的尾部添加一个星号。需要指出的是arrIndex()里面存储的是文本，需要用CInt转换成数字。咦，为什么当初不直接存成数字呢，大概是因为Split返回的只能是字符串数组……

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

R

这是一个很简单的方法，作用就是把上述字典对象销毁再重建，正如它的名称一样，刷新一下字典。ResetAll()方法和InitComboBox1()方法会调用本方法。

Sub RefreshDic()
Set objDic = Nothing
ReadNameList
End Sub

S

这也是一个很简单的方法，把传入的字符串数组转换成数字数组再返回。首先声明一个整型数组，然后修改数组大小，使它跟传入的字符串数组一致。接着对字符串数组遍历，如果能够转换成数字的则转成数字，不能转换的则忽略。最后返回这个整型数组。

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

小结和预告

写代码解析远比想象的无聊啊有木有，看到这里的都是真爱。但是如果你真的想在前一篇的基础上，把这个PPT修改成能满足你实际使用需求的样子，理解这些代码的含义是很有必要的。

按照原计划，在下一篇中我会介绍如何把这个PPT修改成功能更复杂的抽奖程序，事实上，除了抽奖程序，这个PPT还可以用来给一群人分组。比如题图的那个PPT，就是用来把指定的一批人分成5人一组的小组，并且保证每组至少有一个女生。

另外细心的你可能也发现了，题图中的分组PPT不再有丑陋的白底文本框，取而代之是的两个透明的文本框，文本框中的文字也是可以带特殊显示效果的，视觉上比上一版也有了不少进步。这是我在做上述分组PPT的时候偶然发现的新大陆，下一篇一并分享。

针对上一篇中值友们提到的一些修改需求，比如一次抽取5名，比如要把一等奖给某一位位高权重的人（说好了不能有黑幕的呢？），这些我也会一并解答。如果对这些代码的解释有什么疑问，欢迎在评论区提出。

敬请期待！