PPT抽奖程序

hhjjpp

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

hhjjpp

1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '参数是长整形（毫秒数）。Lib “kernel32”标明这个函数是引用kernel32.dll提供的函数。Kernel32.dll是windows的四个核心库之一。是用来延时n毫秒的
   
2. Dim s As New Collection, f As Boolean, j%, n%, temp, prr, frr, orr, nrr, jt$                                 '接受函数返回数组的temp不能 As String
   
3. Private Sub CommandButton1_Click()
   
4. Dim i%, r%
   
5. If j = 0 Then
   
6.    Set s = Nothing
   
7.    Dim app  As Object, xl As Object, m%, arr, xrr, ar, brr(200)
   
8.    Set app = CreateObject("Excel.Application")   '从excel提取数据
   
9.    Set xl = app.workbooks.Open(ActivePresentation.Path & "\限制性抽奖设置-h.xls")
   
10.    ScreenUpdating = False                        'ppt中禁止使用application.ScreenUpdating = False
    
11.    app.Visible = False                           '调试时True确保不隐藏excel窗口
    
12.    With xl.Worksheets("基础数据")                '不能用xl.sheet2
    
13.         m = .[iv1].End(1).Column - 2
    
14.         arr = .[c1].resize(1, m)
    
15.         prr = .[c3].resize(1, .[iv3].End(1).Column - 2)
    
16.         frr = .[c4].resize(1, .[iv4].End(1).Column - 2)
    
17.         orr = .[c5].resize(1, .[iv5].End(1).Column - 2)
    
18.         nrr = .[c6].resize(1, .[iv6].End(1).Column - 2)
    
19.         xrr = .[c7].resize(3, m)
    
20.    End With
    
21.    app.Visible = True
    
22.    xl.Close False:       app.Quit
    
23.    Set xl = Nothing: Set app = Nothing
    
24.    For Each ar In xrr                            'xrr的滤除号码整理为一维数组brr，以便使用filter
    
25.        If ar <> "" Then brr(k) = ar: k = k + 1
    
26.    Next
    
27.    k = 0
    
28.    For i = 1 To m                                '抽奖号码条件滤除
    
29.        If UBound(Filter(brr, arr(1, i))) < 0 Then s.Add arr(1, i), CStr(arr(1, i))
    
30.    Next
    
31.    Erase xrr: Set ar = Nothing: Erase arr: Erase brr   'Erase可代替Set= Nothing,但也不能用于变量
    
32.    j = 1                                         '抽奖序次初始化
    
33.    TextBox4.Text = "三等奖"                      '抽奖界面初始化
    
34.    Me.Shapes("TextBox 14").Visible = True        '可以用me替代ActivePresentation.Slides(1),好爽!
    
35.    Me.Shapes("TextBox 15").Visible = True
    
36.    Me.Shapes("TextBox 16").Visible = True
    
37.    Me.Shapes("TextBox 17").Visible = True
    
38.    Me.Shapes("TextBox 14").TextFrame.TextRange.Text = "三等奖"
    
39.    Me.Shapes("TextBox 15").TextFrame.TextRange.Text = "二等奖"
    
40.    Me.Shapes("TextBox 16").TextFrame.TextRange.Text = "一等奖"
    
41.    Me.Shapes("TextBox 17").TextFrame.TextRange.Text = "特等奖"
    
42. End If
    
43. f = False
    
44. If Me.CommandButton1.Caption = "停止" Then
    
45.    Me.CommandButton1.Caption = "开始"
    
46.    f = True
    
47. Else
    
48.    Me.CommandButton1.Caption = "停止"
    
49.    If j < 5 Then n = --Mid(3321, j, 1) Else n = 0 '抽取各奖等的个数；抽取特别奖置0
    
50.    Do
    
51.       If f Then
    
52.          Select Case j                            '操作汇奖区
    
53.                 Case 1
    
54.                      Me.TextBox5.Text = temp(0) & "   " & temp(1) & "   " & temp(2)
    
55.                      Me.TextBox5.Visible = True
    
56.                      jt = "三等奖          " & TextBox5.Text
    
57.                      Sleep 80                     '延时让抽中号码有机会显示在抽奖区,而非一闪而过飘到汇奖区;调试时可改为800观察
    
58.                      Me.TextBox1.Text = ""        '注意加me,因为slide7也有TextBox;否则会出现清除失效!
    
59.                      Me.TextBox2.Text = ""
    
60.                      Me.TextBox3.Text = ""
    
61.                 Case 2
    
62.                      Me.TextBox6.Text = temp(0) & "   " & temp(1) & "   " & temp(2)
    
63.                      Me.TextBox6.Visible = True
    
64.                      jt = "二等奖          " & TextBox6.Text & vbCrLf & jt
    
65.                      Sleep 80
    
66.                      Me.TextBox1.Text = ""
    
67.                      Me.TextBox2.Text = ""
    
68.                      Me.TextBox3.Text = ""
    
69.                 Case 3
    
70.                      Me.TextBox7.Text = temp(0) & "    " & temp(1)
    
71.                      Me.TextBox7.Visible = True
    
72.                      jt = "一等奖            " & TextBox7.Text & vbCrLf & jt
    
73.                      Sleep 80
    
74.                      Me.TextBox1.Text = ""
    
75.                      Me.TextBox3.Text = ""
    
76.                 Case 4
    
77.                      Me.TextBox8.Text = temp(0)
    
78.                      Me.TextBox8.Visible = True
    
79.                      jt = "特等奖               " & TextBox8.Text & vbCrLf & jt
    
80.                      Sleep 80
    
81.                      Me.TextBox2.Text = ""
    
82.                 Case 5
    
83.                      Me.Shapes("TextBox 14").TextFrame.TextRange.Text = "生产线员工奖"
    
84.                      Me.Shapes("TextBox 14").Visible = True
    
85.                      TextBox5.Text = temp
    
86.                      jt = jt & vbCrLf & vbCrLf & "生产线员工奖         " & temp
    
87.                      Sleep 80
    
88.                      Me.TextBox2.Text = ""
    
89.                      Me.TextBox4.Text = "办公室员工奖"
    
90.                 Case 6
    
91.                      Me.Shapes("TextBox 15").TextFrame.TextRange.Text = "办公室员工奖"
    
92.                      Me.Shapes("TextBox 15").Visible = True
    
93.                      TextBox6.Text = temp
    
94.                      jt = jt & vbCrLf & "办公室员工奖         " & temp
    
95.                      Sleep 80
    
96.                      Me.TextBox2.Text = ""
    
97.                      Me.TextBox4.Text = "老员工奖"
    
98.                  Case 7
    
99.                      Me.Shapes("TextBox 16").TextFrame.TextRange.Text = "老员工奖"
    
100.                      Me.Shapes("TextBox 16").Visible = True
     
101.                      TextBox7.Text = temp
     
102.                      jt = jt & vbCrLf & "老员工奖             " & temp
     
103.                      Sleep 80
     
104.                      Me.TextBox2.Text = ""
     
105.                      Me.TextBox4.Text = "新员工奖"
     
106.                  Case 8
     
107.                      Me.Shapes("TextBox 17").TextFrame.TextRange.Text = "新员工奖"
     
108.                      Me.Shapes("TextBox 17").Visible = True
     
109.                      Me.TextBox8.Text = temp
     
110.                      jt = jt & vbCrLf & "新员工奖             " & temp
     
111.                      Sleep 100
     
112.                      Me.TextBox2.Text = ""
     
113.          End Select
     
114.          j = j + 1
     
115.          Select Case j
     
116.                 Case 5
     
117.                      MsgBox "按“确定”按钮,开始抽取特别奖！"
     
118.                      Me.Shapes("副标题 2").TextFrame.TextRange.Text = "附加特别奖"
     
119.                      Me.TextBox5.Text = "": Me.TextBox6.Text = "": Me.TextBox7.Text = "": Me.TextBox8.Text = ""
     
120.                      Me.Shapes("TextBox 14").Visible = False: Me.Shapes("TextBox 15").Visible = False
     
121.                      Me.Shapes("TextBox 16").Visible = False: Me.Shapes("TextBox 17").Visible = False
     
122.                      TextBox4.Text = "生产线员工奖"
     
123.                      Set s = Nothing                '集合s抽取特别奖时不需
     
124.                 Case 9                              '抽奖结束
     
125.                      SlideShowWindows(1).View.Next
     
126.                      Slide7.Shapes("Text Box 6").TextFrame.TextRange.Text = jt
     
127.                      j = 0
     
128.                      Me.Shapes("副标题 2").TextFrame.TextRange.Text = "幸运大抽奖活动"
     
129.                      Me.TextBox4.Text = "": Me.TextBox5.Text = "": Me.TextBox6.Text = "": Me.TextBox7.Text = "": Me.TextBox8.Text = ""
     
130.                      Me.Shapes("TextBox 14").Visible = False: Me.Shapes("TextBox 15").Visible = False
     
131.                      Me.Shapes("TextBox 16").Visible = False: Me.Shapes("TextBox 17").Visible = False
     
132.                      ScreenUpdating = True
     
133.                      Exit Sub
     
134.                 Case 2 To 4
     
135.                      For i = 0 To n - 1
     
136.                          s.Remove (temp(i))         '滤除已抽取号码
     
137.                      Next
     
138.                      Me.TextBox4.Text = Mid("三二一特", j, 1) & "等奖" '显示待抽的下一奖等
     
139.          End Select
     
140.          Exit Do                                    '退出快闪循环准备下一轮抽奖
     
141.       Else
     
142.          If n Then
     
143.             temp = choose(s.Count, n)                's.count意味着已扣减抽取的样本
     
144.             For i = 0 To n - 1                       '由于temp抽取的序号并未排序，s.remove时可能会造成s(--temp(i))中当时序标--temp(i)的变动和丢失，故在remove之前存好s(--temp(i)),而非存序号
     
145.                 temp(i) = s(--temp(i)) & ""          'choose作为字典的key已置为文本
     
146.             Next
     
147.             Select Case n                            '下框的抽奖区即时显示具体抽中号码
     
148.                    Case 3
     
149.                         Me.TextBox1.Visible = True      '因上次抽特等奖时将其隐藏
     
150.                         Me.TextBox3.Visible = True
     
151.                         Me.TextBox1.Text = temp(0): Me.TextBox2.Text = temp(1): Me.TextBox3.Text = temp(2)
     
152.                    Case 2
     
153.                         Me.TextBox1.Text = temp(0): Me.TextBox3.Text = temp(1)
     
154.                         Me.TextBox2.Visible = False
     
155.                    Case 1
     
156.                         Me.TextBox1.Visible = False: Me.TextBox2.Visible = True: Me.TextBox3.Visible = False
     
157.                         Me.TextBox2.Text = temp(0)
     
158.             End Select
     
159.          Else
     
160.             Randomize
     
161.             Select Case j                            '下框的抽奖区即时显示特别奖具体抽中号码
     
162.                    Case 5
     
163.                         temp = prr(1, Int(Rnd * UBound(prr, 2)) + 1)
     
164.                         Me.TextBox2.Text = temp
     
165.                    Case 6
     
166.                         temp = frr(1, Int(Rnd * UBound(frr, 2)) + 1)
     
167.                         Me.TextBox2.Text = temp
     
168.                    Case 7
     
169.                         temp = orr(1, Int(Rnd * UBound(orr, 2)) + 1)
     
170.                         Me.TextBox2.Text = temp
     
171.                    Case 8
     
172.                         temp = nrr(1, Int(Rnd * UBound(nrr, 2)) + 1)
     
173.                         Me.TextBox2.Text = temp
     
174.             End Select
     
175.          End If
     
176.       End If
     
177.       Sleep 30
     
178.       DoEvents
     
179.    Loop
     
180. End If
     
181. End Sub
     
182. Function choose(m%, n%)             'm选n；传回数组的函数不能声明为String，必须为vaiant
     
183. Dim i%, dt
     
184. Set dt = CreateObject("Scripting.Dictionary")
     
185. Randomize
     
186. Do
     
187.    i = Int(Rnd * (m - 1)) + 1
     
188.    dt(i & "") = ""                  '用字典的key来确保不重复抽取
     
189. Loop Until dt.Count = n
     
190. choose = dt.keys
     
191. End Function
     

复制代码

weiyingde

hhjjpp 发表于 2016-12-17 21:39

孜孜以求，不断完美，中见巅峰大作。再用更新，收入囊中，以备后用。谢谢了。

weiyingde

hhjjpp 发表于 2016-12-17 21:39

少了与之连用的“限制性抽奖设置-h.xls“文件，测试无法进行。

hhjjpp

weiyingde 发表于 2016-12-18 10:49
少了与之连用的“限制性抽奖设置-h.xls“文件，测试无法进行。

是我疏漏！

weiyingde

测试可以，只是刷新较慢，有撤屏卡顿之感，若完善一下更好

亦feng

好好学习下，有意思

小小的尼玛

厉害了，谢谢大侠辛苦工作

leikaiyi123

http://club.excelhome.net/thread-1126548-3-1.html
见27楼

superscorpius

这个为什么我点开没反应啊？？