PPT抽奖程序

chem_87

撸了几种PPT抽奖的方法
1是在每页PPT上写好名字，然后循环播放
2是用VBA，本例是利用VBA进行抽奖

1. Private Sub CommandButton1_Click()
   
2.     If Me.CommandButton1.Caption = "停" Then
   
3.         Me.CommandButton1.Caption = "开始"
   
4.         Call CQ_do("stop")
   
5.     Else
   
6.         Me.CommandButton1.Caption = "停"
   
7.         Call CQ_do("start")
   
8.     End If
   
9. End Sub
   
10. 
    
11. 
    
12. Private Sub CQ_do(doTag)
    
13.     Dim I, arr1(1 To 5), sr$
    
14.     Set d = CreateObject("scripting.dictionary")
    
15.    
    
16.     If doTag = "start" Then
    
17.         arrRM = Split(Slide2.Shapes("文本框 2").TextEffect.Text, "、", -1, 1)  '如果有需要你可以替换这里的空格，改为你需要的分隔符： 如个为英文分号 Split(Me.TextBox1, ";", -1, 1)
    
18.         F = 0
    
19.         Do While True
    
20.         sr = ""
    
21.             For x = 1 To 5
    
22. 100:
    
23.               num = Int(((UBound(arrRM) - 0) + 1) * Rnd()) + 0
    
24.               If d.exists(num) Then
    
25.                 GoTo 100
    
26.               Else
    
27.                 d(num) = ""
    
28.                 arr1(x) = arrRM(num)
    
29.               End If
    
30.             Next x
    
31.             d.RemoveAll
    
32.             'I = Int(((UBound(arrRM) + 1) * Rnd) + 0)
    
33.             For x = 1 To 5
    
34.                 sr = sr & arr1(x) & Chr(10)
    
35.             Next
    
36.             Slide2.Shapes("文本框 1").TextEffect.Text = sr
    
37.             If F = 1 Then Exit Do
    
38.             DoEvents
    
39.         Loop
    
40.         sr = ""
    
41.         'TextBox1.Text = Replace(TextBox1.Text, TextBox2.Text, "")  '删除已经被抽取的名单，不在重复抽取
    
42.         'TextBox1.Text = Replace(TextBox1.Text, "  ", " ")
    
43.     Else
    
44.         F = 1
    
45.     End If
    
46. End Sub

复制代码

morpheus126

挺不错的，谢谢分享！

十五的星星

如果开始抽奖结果不显示就好了，开始还没抽，抽奖结果就显示了5个人