PPT抽奖VBA实例

Author：氷
发布时间：June 29, 2024
134 views
One comment
3433 words
Categories： Windows

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

![效果演示](https://www4.iceyer.cn:444/usr/uploads/2024/06/144530364.gif)

# 一、使用

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

# 二、注意

1. 因为是开发者文本框控件，预览幻灯片前后均可编辑，所以可以很方便的实时编辑，但是此控件背景颜色透明属性可以忽略，只能用纯色代替，导致很生硬，固加了形状衬底。
2. 每次操作都会保留，如果PPT保存后，操作也会保留。
3. 每个号码用空格` `分割，最后一个号码尾部无需空格。
4. 每个号码最大支持四位数，多了需要修改字体大小或字体，否则显示不完整。
5. 如果多个环节抽奖：
   * 号码池继续，推荐使用`幻灯片缩放定位`的方式复用幻灯片；
   * 号码池重建，直接`复制幻灯片`即可，VBA代码会自动复制。
6. 涉及VBA代码，说明使用了宏功能，保存文件时记得选择`.pptm`。
7. 控件名称为英文的为VBA和动画调用，修改的话请与VBA代码保持一致。

![选择窗口](https://www4.iceyer.cn:444/usr/uploads/2024/06/3294794954.png)

```vbnet
' 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赋值明显卡顿，无奈又换回了开发者控件，好在可以用形状衬底并且还支持预览时播放，也挺好的。也想过写个网页在调用，但是本地浏览器环境问题会报错弹窗，最终只能采用此方法，如有更好的方法欢迎评论区或加群讨论。

# 四、下载

<button class=" btn m-b-xs btn-light btn-rounded " onclick="window.open('https://www4.iceyer.cn:444/usr/uploads/2024/06/2923162191.zip','_blank')">VBA抽奖.zip</button>

Last modification：June 29, 2024

喜欢我的文章吗？别忘了点赞或赞赏，让我知道创作的路上有你陪伴。

One comment

gyyzjarbig
4 Weeks Ago

《桃花朵朵开》喜剧片高清在线免费观看：https://www.jgz518.com/xingkong/78990.html

Reply

PPT抽奖VBA实例

氷 • 2024 年 06 月 29 日

![效果演示](https://www4.iceyer.cn:444/usr/uploads/2024/06/144530364.gif)

# 一、使用

# 二、注意

![选择窗口](https://www4.iceyer.cn:444/usr/uploads/2024/06/3294794954.png)

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

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

# 三、后记

# 四、下载

<button class=" btn m-b-xs btn-light btn-rounded " onclick="window.open('https://www4.iceyer.cn:444/usr/uploads/2024/06/2923162191.zip','_blank')">VBA抽奖.zip</button>

PPT抽奖VBA实例

One comment

Leave a Comment Cancel reply
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

群晖NAS Docker运行Clash与yacd

Home Assistant——HACS添加代理提升下载速度

便(垃)携(圾)主机——小米mix2s+ipad3屏幕+displaylink扩展坞！！！

Home Assistant——云音乐ha_cloud_music（播放的不是对应的音乐？）

全网首发群晖DSM7.0部署inis

nginx 防盗链

SC-系统部署模块

Windows 10 LTSC 2021 安装微软商店

CAD钢筋符号已替换tssdeng.shx字体，但还是显示问号？

PPT抽奖VBA实例

PPT抽奖VBA实例

One comment

Leave a Comment Cancel reply 使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

PPT抽奖VBA实例

Leave a Comment Cancel reply
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款