PPT抽奖程序

wqpwjw · 2017-2-6 16:10:22

大师们，请教PPT里做个抽奖程序怎么弄？801-850 50个号码
抽奖时号码滚动显示，抽中的号码不能被重复抽奖

抽奖---.zip (84.58 KB, 下载次数: 68)

jxzbsx · 2017-2-6 18:49:50

请各位路过的网友注意，以上附件均有重大瑕疵，可能造成重复，而应以此附件为依据。
原因在于用filter滤除由choose函数返回的temp数组隐含逻辑漏洞，关键在于temp数组未从大到小排序：temp作为arr数组的下标，如果先滤除的数组元素temp(0)<temp(1)，就会影响到后滤除的数组目标，因为滤后下标会前移，而choose函数得到是滤除之前的arr数组的下标。
鉴于此，已利用带key的集合**解决此问题，因为集合remove依据的不是序号，而是精准的key值；但是本层附件，仍有足以引起争议的瑕疵，因为滚动抽奖区所显示的最终抽中结果可能与右侧汇奖区显示的号码不一致（目前尚未解决，见），目前采用的策略是抽奖区只显示滚动效果，而让4次抽奖结果极速闪过，瞬飘至汇奖区。

依次逐等抽奖并集中抽奖结果----h.rar (55 KB, 下载次数: 75)

yunqiao · 2017-2-6 17:33:33

大侠们，请赐教！

cyy_8888 · 2017-2-6 17:38:50

请高手赐教

richwan · 2017-2-6 17:41:08

PPT里嵌入VBA做这个抽奖程序怎么弄啊?高手

人在旅途 · 2017-2-6 17:46:05

沉了吗？自己顶一下，期待高手指点

wei_shaowe · 2017-2-6 17:51:33

期待高手赐教

waittree · 2017-2-6 17:53:03

在最后slide
用放映模式方可抽奖

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '参数是长整形（毫秒数）。Lib “kernel32”标明这个函数是引用kernel32.dll提供的函数。Kernel32.dll是windows的四个核心库之一。是用来延时n毫秒的?
Dim arr, f As Boolean, j%, n%, temp '接受函数返回数组的temp不能 As String
Private Sub CommandButton1_Click()
Dim i%, r%
If IsEmpty(arr) Then
TextBox1.Visible = True
TextBox3.Visible = True
TextBox2.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
ReDim arr(1 To 50)
For i = 1 To 50
arr(i) = 800 + i
Next
j = 1
TextBox4.Text = "三等奖"
End If
If Me.CommandButton1.Caption = "停止" Then
Me.CommandButton1.Caption = "开始"
f = True
'MsgBox f & j '因只能在放映模式使用按钮,调试设置变量监控点
Select Case j
Case 1
TextBox5.Text = arr(temp(0)) & " " & arr(temp(1)) & " " & arr(temp(2))
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
Case 2
TextBox6.Text = arr(temp(0)) & " " & arr(temp(1)) & " " & arr(temp(2))
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
Case 3
TextBox7.Text = arr(temp(0)) & " " & arr(temp(1))
TextBox1.Text = ""
TextBox3.Text = ""
Case 4
TextBox8.Text = arr(temp(0))
TextBox2.Text = ""
End Select
'MsgBox n & j '变量监控点
For i = 0 To n - 1
arr = Filter(arr, arr(temp(i)), False) '滤除已抽取号码
Next
If j = 4 Then
MsgBox "抽奖完毕！"
Exit Sub
End If
j = j + 1
TextBox4.Text = Mid("三二一特", j, 1) & "等奖"
Else
Me.CommandButton1.Caption = "停止"
f = False
'MsgBox f & j '变量监控点
n = --Mid(3321, j, 1) '抽取奖等个数
r = Mid("0368", j, 1) '抽剩应扣减样本数量
'MsgBox r '变量监控点
Do
Sleep 10
If f Then Exit Do
temp = choose(50 - r, n)
Select Case n
Case 3
TextBox1.Visible = True
TextBox2.Visible = True
TextBox3.Visible = True
TextBox1.Text = arr(temp(0))
TextBox2.Text = arr(temp(1))
TextBox3.Text = arr(temp(2))
Case 2
TextBox1.Text = arr(temp(0))
TextBox2.Visible = False
TextBox3.Text = arr(temp(1))
Case 1
TextBox1.Visible = False
TextBox2.Visible = True
TextBox3.Visible = False
TextBox2.Text = arr(temp(0))
End Select
DoEvents
Loop
End If
End Sub
Function choose(m%, n%) '传回数组的函数不能声明为String，必须为vaiant
Dim i%, dt
Set dt = CreateObject("Scripting.Dictionary")
Randomize
Do
i = Int(Rnd * (m - 1)) + 1
dt(i & "") = "" '用字典的key来确保不重复抽取
Loop Until dt.Count = n
choose = dt.keysEnd Function

复制代码

worthyman · 2017-2-6 17:55:49

再次优化代码：

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '参数是长整形（毫秒数）。Lib “kernel32”标明这个函数是引用kernel32.dll提供的函数。Kernel32.dll是windows的四个核心库之一。是用来延时n毫秒的?
Dim arr, f As Boolean, j%, n%, temp '接受函数返回数组的temp不能 As String
Private Sub CommandButton1_Click()
Dim i%, r%
If IsEmpty(arr) Then
TextBox1.Visible = True '因上次抽特等奖时将其隐藏
TextBox3.Visible = True
TextBox2.Text = "" '清除界面的上次奖等数据
TextBox4.Text = ""
TextBox5.Visible = False
TextBox6.Visible = False
TextBox7.Visible = False
TextBox8.Visible = False
ReDim arr(1 To 50)
For i = 1 To 50 '抽奖号码准备
arr(i) = 800 + i
Next
j = 1 '抽奖序次初始化
TextBox4.Text = "三等奖"
End If
If Me.CommandButton1.Caption = "停止" Then
Me.CommandButton1.Caption = "开始"
f = True
'MsgBox f & j '因只能在放映模式使用按钮,调试设置变量监控点
Select Case j '汇集抽奖结果
Case 1
TextBox5.Text = arr(temp(0)) & " " & arr(temp(1)) & " " & arr(temp(2))
TextBox5.Visible = True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
Case 2
TextBox6.Text = arr(temp(0)) & " " & arr(temp(1)) & " " & arr(temp(2))
TextBox6.Visible = True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
Case 3
TextBox7.Text = arr(temp(0)) & " " & arr(temp(1))
TextBox7.Visible = True
TextBox1.Text = ""
TextBox3.Text = ""
Case 4
TextBox8.Text = arr(temp(0))
TextBox8.Visible = True
End Select
'MsgBox n & j '变量监控点
j = j + 1
If j = 5 Then
MsgBox "抽奖完毕！"
Exit Sub
End If
For i = 0 To n - 1
arr = Filter(arr, arr(temp(i)), False) '滤除已抽取号码
Next
TextBox4.Text = Mid("三二一特", j, 1) & "等奖" '显示待抽的下一奖等
Else
Me.CommandButton1.Caption = "停止"
f = False
'MsgBox f & j '变量监控点
n = --Mid(3321, j, 1) '抽取奖等的个数
r = Mid("0368", j, 1) '抽剩应扣减样本数量
'MsgBox r '变量监控点
Do
Sleep 10
If f Then Exit Do
temp = choose(50 - r, n) '50-r选n
Select Case n '下框显示具体抽中号码
Case 3
TextBox1.Visible = True
TextBox2.Visible = True
TextBox3.Visible = True
TextBox1.Text = arr(temp(0))
TextBox2.Text = arr(temp(1))
TextBox3.Text = arr(temp(2))
Case 2
TextBox1.Text = arr(temp(0))
TextBox2.Visible = False
TextBox3.Text = arr(temp(1))
Case 1
TextBox1.Visible = False
TextBox2.Visible = True
TextBox3.Visible = False
TextBox2.Text = arr(temp(0))
End Select
DoEvents
Loop
End If
End Sub
Function choose(m%, n%) '传回数组的函数不能声明为String，必须为vaiant
Dim i%, dt
Set dt = CreateObject("Scripting.Dictionary")
Randomize
Do
i = Int(Rnd * (m - 1)) + 1
dt(i & "") = "" '用字典的key来确保不重复抽取
Loop Until dt.Count = n
choose = dt.keys
End Function

复制代码

ltl324 · 2017-2-6 17:58:26

因发帖无反馈造成重复发帖，请删除！

su7212 · 2017-2-6 18:00:39

在最后slide，需要在放映模式抽奖
这个用在32位操作系统中：

抽奖-h.rar (68.28 KB, 下载次数: 182)

		自动登录	找回密码
密码			立即注册

PPT抽奖程序

本帖被以下精选资料库推荐:

相关帖子