PPT抽奖程序

gtyihui

尚有瑕疵，中奖事宜事关重大，应以此为准：
依次逐等抽奖并集中抽奖结果-h.rar (75.34 KB, 下载次数: 151)

2017-2-13 12:18 上传

点击文件名下载附件

jxzbsx

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

2017-2-13 12:21 上传

点击文件名下载附件

dns.ldm

不错，很好！！

etymet

删除集合元素代码有误，特此纠正：

1. 
   
2. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '参数是长整形（毫秒数）。Lib “kernel32”标明这个函数是引用kernel32.dll提供的函数。Kernel32.dll是windows的四个核心库之一。是用来延时n毫秒的?
   
3. Dim s As New Collection, f As Boolean, j%, n%, temp                                    '接受函数返回数组的temp不能 As String;不关闭ppt,上次的arr将一直存在,这是与在下面声明的差异
   
4. Private Sub CommandButton1_Click()
   
5. Dim i%, r%
   
6. If s.Count < 50 And j = 0 Then               '不能用s.Count=0,连续调试时避免中断执行造成少于50个元素存在，一开始就无法进行j=1的初始化
   
7.    TextBox2.Text = ""                        '清除界面的上次奖等数据
   
8.    TextBox4.Text = ""
   
9.    TextBox5.Visible = False
   
10.    TextBox6.Visible = False
    
11.    TextBox7.Visible = False
    
12.    TextBox8.Visible = False
    
13.    TextBox5.Text = ""
    
14.    TextBox6.Text = ""
    
15.    TextBox7.Text = ""
    
16.    TextBox8.Text = ""
    
17.    Set s = Nothing
    
18.    For i = 1 To 50                           '抽奖号码准备
    
19.        s.Add 800 + i, CStr(800 + i)
    
20.    Next
    
21.    j = 1                                     '抽奖序次初始化
    
22.    TextBox4.Text = "三等奖"
    
23. End If
    
24. f = False
    
25. If Me.CommandButton1.Caption = "停止" Then
    
26.    Me.CommandButton1.Caption = "开始"
    
27.    f = True
    
28. Else
    
29.    Me.CommandButton1.Caption = "停止"
    
30.    'MsgBox f & j                             '因只能在放映模式使用按钮,调试时变量监控点
    
31.    n = --Mid(3321, j, 1)                     '抽取奖等的个数
    
32.    Do
    
33.       If f Then
    
34.          Select Case j                       '操作汇奖区
    
35.                 Case 1
    
36.                      TextBox5.Text = temp(0) & " " & temp(1) & " " & temp(2)
    
37.                      TextBox5.Visible = True
    
38.                      Sleep 80               '延时让抽中号码有机会显示在抽奖区,而非一闪而过飘到汇奖区,调试改为800
    
39.                      TextBox1.Text = ""
    
40.                      TextBox2.Text = ""
    
41.                      TextBox3.Text = ""
    
42.                 Case 2
    
43.                      TextBox6.Text = temp(0) & " " & temp(1) & " " & temp(2)
    
44.                      TextBox6.Visible = True
    
45.                      Sleep 80
    
46.                      TextBox1.Text = ""
    
47.                      TextBox2.Text = ""
    
48.                      TextBox3.Text = ""
    
49.                 Case 3
    
50.                      TextBox7.Text = temp(0) & " " & temp(1)
    
51.                      TextBox7.Visible = True
    
52.                      Sleep 80
    
53.                      TextBox1.Text = ""
    
54.                      TextBox3.Text = ""
    
55.                 Case 4
    
56.                      TextBox8.Text = temp(0)
    
57.                      TextBox8.Visible = True
    
58.                      TextBox2.Text = ""
    
59.          End Select
    
60.          'MsgBox n & j                         '调试时变量监控点
    
61.          j = j + 1
    
62.          If j = 5 Then
    
63.             MsgBox "抽奖完毕！"
    
64.             j = 0
    
65.             Exit Sub
    
66.          Else
    
67.             For i = 0 To n - 1
    
68.                 s.Remove (temp(i))              '滤除已抽取号码
    
69.             Next
    
70.          End If
    
71.          TextBox4.Text = Mid("三二一特", j, 1) & "等奖" '显示待抽的下一奖等
    
72.          Exit Do
    
73.       Else
    
74.          temp = choose(50 - Mid("0368", j, 1), n) '扣减已抽取样本数量,50-Mid("0368", j, 1)选n
    
75.          For i = 0 To n - 1                    '由于temp抽取的序号并未排序，s.remove时可能会造成s(--temp(i))中--temp(i)的变动和丢失，故在remove之前存好s(--temp(i)),而非存序号
    
76.              temp(i) = s(--temp(i)) & ""       'choose作为字典的key已置为文本
    
77.          Next
    
78.          Select Case n                         '下框的抽奖区即时显示具体抽中号码
    
79.                 Case 3
    
80.                   TextBox1.Visible = True      '因上次抽特等奖时将其隐藏
    
81.                   TextBox3.Visible = True
    
82.                   TextBox1.Text = temp(0)
    
83.                   TextBox2.Text = temp(1)
    
84.                   TextBox3.Text = temp(2)
    
85.                 Case 2
    
86.                   TextBox1.Text = temp(0)
    
87.                   TextBox2.Visible = False
    
88.                   TextBox3.Text = temp(1)
    
89.                 Case 1
    
90.                   TextBox1.Visible = False
    
91.                   TextBox2.Visible = True
    
92.                   TextBox3.Visible = False
    
93.                   TextBox2.Text = temp(0)
    
94.          End Select
    
95.       End If
    
96.       Sleep 30
    
97.       DoEvents
    
98.    Loop
    
99. End If
    
100. End Sub
     
101. Function choose(m%, n%)             '传回数组的函数不能声明为String，必须为vaiant
     
102. Dim i%, dt
     
103. Set dt = CreateObject("Scripting.Dictionary")
     
104. Randomize
     
105. Do
     
106.    i = Int(Rnd * (m - 1)) + 1
     
107.    dt(i & "") = ""                  '用字典的key来确保不重复抽取
     
108. Loop Until dt.Count = n
     
109. choose = dt.keysEnd Function

复制代码

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

2017-2-13 12:24 上传

点击文件名下载附件

养只鸽子

只是附件界面丑了点，终于抽时间改了：




限制性抽奖并汇集抽奖结果-h.rar (77.38 KB, 下载次数: 28)

2017-2-13 12:25 上传

点击文件名下载附件

限制性抽奖设置-h.rar (14.33 KB, 下载次数: 189)

2017-2-13 12:25 上传

点击文件名下载附件

sunyefeng

又修改了，见完美之作。
有空琢磨一下。
大侠令人佩服，ppt接触时间之短，进步之快，令人汗颜。
有空多向你讨教。
希望不吝赐教。

tanghua

太过奖了，只是一点表面功夫而已！
我一直没搞明白slide对象之间的关系，图1编辑窗口左侧显示有两页幻灯片，图2的vbe窗口则只有slide6这一个对象，那就是说图1的2#幻灯片式是slide6对象之下的，在本地窗口下的me下面也确实看不到2#幻灯片的两个shapes（其实就是插入新幻灯片时母版的的标题和下面正文文本框，模块里的录制宏可以看到分别为.Shapes(&quot;Rectangle 2&quot;)对象和.Shapes(&quot;Rectangle 3&quot;)），但就是无法用ActivePresentation.Slides(1).Shapes(&quot;Rectangle 2&quot;).TextFrame.TextRange.Text = &quot;年终幸运榜&quot;赋值，或slide6.Shapes(&quot;Rectangle 2&quot;).TextFrame.TextRange.Text = &quot;年终幸运榜&quot;，究竟该如何表示slide6第2页的shape对象？
其实我的目的，就是结束时用另一个幻灯片来替代小家子气的msgbox抽奖结果。

广西莫老爷

slide对象和ActiveWindow.Selection对象之下sliderange集合又是个什么关系？也一直没弄明白，总之ppt的对象层级关系都是稀里糊涂的！

yh1680

这是两个不同的概念。
这相当于excel中有五种模块一样：标准模块、类模块、工作表模块、工作簿模块、窗体模块。
而ppt中的模块的模块也有五个：标准模块、类模块、幻灯片母板模块、幻灯片模块、窗体模块。
但excel和ppt中VBA工程窗口同中有异：
同：两者都可以通过插入命令插入标准模块、类模块、窗体模块。
异：excel中工作表模块、工作簿模块本来就存在
    ppt中幻灯片母板模块、幻灯片模块在工程窗口中本来没有，也不能通过插入命令插入。
    只能通过在母版或幻灯片中插入控件，再右击查看代码，就兴建了相应的模块。

李代珍

混沌之下，还是焕然一新了：


限制性抽奖并汇集抽奖结果-h.rar (76.9 KB, 下载次数: 154)

2017-2-13 12:29 上传

点击文件名下载附件