之前在公司制作年会PPT，中途需要一个现场抽奖环节，当时用了多种方式，最后采用VBA+开发者控件实现。最近整理文件，优化了一些逻辑与样式，绝对的原创，转载请注明。

一、使用

1. 在抽奖名单设置需要抽奖的号码。
2. 点击复位按钮，会把抽奖名单放入候选名单中等待开始抽奖，同时会清空中奖名单。
3. 点击开始按钮，会从候选名单随机轮播一个号码，直到点击停止按钮。
4. 点击停止按钮，轮播号码会暂停，从候选名单移入中奖名单，同时播放烟花动画。

二、注意

1. 因为是开发者文本框控件，预览幻灯片前后均可编辑，所以可以很方便的实时编辑，但是此控件背景颜色透明属性可以忽略，只能用纯色代替，导致很生硬，固加了形状衬底。
2. 每次操作都会保留，如果PPT保存后，操作也会保留。
3. 每个号码用空格 分割，最后一个号码尾部无需空格。
4. 每个号码最大支持四位数，多了需要修改字体大小或字体，否则显示不完整。

5. 如果多个环节抽奖：

   • 号码池继续，推荐使用幻灯片缩放定位的方式复用幻灯片；
   • 号码池重建，直接复制幻灯片即可，VBA代码会自动复制。
6. 涉及VBA代码，说明使用了宏功能，保存文件时记得选择.pptm。
7. 控件名称为英文的为VBA和动画调用，修改的话请与VBA代码保持一致。

' IceYer原创，转载请注明
' 声明Sleep函数，用于暂停执行一定时间
#If Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' 64位
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' 32位
#End If


Dim isInitialize As Boolean ' 初始化是否完成
Dim isLotteryRunning As Boolean ' 预览候选是否正在运行
Dim candidates() As String ' 记录当前候选名单到数组
Dim currentIndex As Integer ' 记录当前候选名单数组的索引
Dim delayTime As Long ' 刷新候选名单的延时

' 重置抽奖状态
Sub ResetLottery()
    ' 将候选名单重置为初始抽奖名单
    TextBox_CandidateList.Text = TextBox_LotteryList.Text
  
    ' 清空之前的获奖者名单
    TextBox_WinnerList.Text = ""
End Sub

' 开始抽奖程序
Sub StartLottery()
    ' 将候选名单分割为单个候选项数组
    candidates = Split(TextBox_CandidateList.Text, " ")

    ' 检查候选名单是否为空
    If UBound(candidates) = -1 Or (UBound(candidates) = 0 And candidates(0) = "") Then
        MsgBox "候选名单为空！", vbExclamation, "错误"
        Exit Sub
    End If
    ' 检查是否只剩一个候选者
    If UBound(candidates) = 0 Then
        MsgBox "只剩一位候选者！", vbInformation, "提示"
        TextBox_LotteryPreview.Text = candidates(0) ' 显示最后一个成员
        Exit Sub
    End If

    ' 标记抽奖正在进行
    isLotteryRunning = True
  
    ' 循环候选名单
    Dim index As Integer
    Do While isLotteryRunning
        ' 随机选择一个候选项
        index = Int((UBound(candidates) + 1) * Rnd)
        currentIndex = index ' 保存当前候选项的索引
        TextBox_LotteryPreview.Text = candidates(index) ' 显示当前选中的候选项

        DoEvents ' 允许系统处理其他事件
        Sleep 50
    Loop
End Sub

' 停止抽奖程序
Sub StopLottery()
    ' 检查抽奖是否正在进行
    If isLotteryRunning Then
        ' 标记抽奖结束
        isLotteryRunning = False
  
        ' 获取当前时间并格式化
        Dim currentTime As String
        currentTime = Format(Now, "hh:nn:ss")
  
        ' 将中奖者添加到获奖者名单
        TextBox_WinnerList.Text = TextBox_WinnerList.Text & _
            currentTime & " " & TextBox_LotteryPreview.Text & vbCrLf
  
        ' 从候选名单中移除中奖者
        Dim i As Integer, j As Integer
        j = 0
        Dim tempCandidates() As String
        ReDim tempCandidates(UBound(candidates) - 1)
        For i = LBound(candidates) To UBound(candidates)
            If i <> currentIndex Then
                tempCandidates(j) = candidates(i)
                j = j + 1
            End If
        Next i
        TextBox_CandidateList.Text = Join(tempCandidates, " ")
    End If
End Sub

三、后记

尝试过使用PPT文本框，样式美观，但VBA赋值明显卡顿，无奈又换回了开发者控件，好在可以用形状衬底并且还支持预览时播放，也挺好的。也想过写个网页在调用，但是本地浏览器环境问题会报错弹窗，最终只能采用此方法，如有更好的方法欢迎评论区或加群讨论。

四、下载

VBA抽奖.zip