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

最新推荐文章于 2023-08-07 16:12:35 发布

ChessZH

最新推荐文章于 2023-08-07 16:12:35 发布

阅读量6.4k

点赞数 12

分类专栏：实用片段

本文链接：https://blog.csdn.net/xiangQiAtCSDN/article/details/89057898

版权

实用片段专栏收录该内容

4 篇文章 0 订阅

订阅专栏

概述

这个博客主要记录了使用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”，打开这个文本文档，把抽奖名单输入到这个文本文档里面。每行一个名字，然后保存、关闭文本文档。

然后就可以使用了！

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

ChessZH

关注

12
点赞
踩
45

收藏

觉得还不错? 一键收藏
14
评论
使用VBA脚本在ppt里实现效果比较成熟的抽奖系统

目录概述过程添加页面控件添加控件响应代码添加引用项调整奖项添加抽奖名单然后就可以使用了！概述这个博客主要记录了使用VBA在ppt里制作较精美的抽奖系统的过程（注：这个方法仅在Windows操作系统可以实现）（另注：只有Microsoft Office的ppt（没有x）可以实现）过程添加页面控件在Microsoft office里找，打开默认关闭的“开发工具”然后根据自己的需求把pp...
复制链接

扫一扫