|
|
- Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '参数是长整形（毫秒数）。Lib “kernel32”标明这个函数是引用kernel32.dll提供的函数。Kernel32.dll是windows的四个核心库之一。是用来延时n毫秒的
- Dim s As New Collection, f As Boolean, j%, n%, temp, prr, frr, orr, nrr, jt$ '接受函数返回数组的temp不能 As String
- Private Sub CommandButton1_Click()
- Dim i%, r%
- If j = 0 Then
- Set s = Nothing
- Dim app As Object, xl As Object, m%, arr, xrr, ar, brr(200)
- Set app = CreateObject("Excel.Application") '从excel提取数据
- Set xl = app.workbooks.Open(ActivePresentation.Path & "限制性抽奖设置-h.xls")
- ScreenUpdating = False 'ppt中禁止使用application.ScreenUpdating = False
- app.Visible = False '调试时True确保不隐藏excel窗口
- With xl.Worksheets("基础数据") '不能用xl.sheet2
- m = .[iv1].End(1).Column - 2
- arr = .[c1].resize(1, m)
- prr = .[c3].resize(1, .[iv3].End(1).Column - 2)
- frr = .[c4].resize(1, .[iv4].End(1).Column - 2)
- orr = .[c5].resize(1, .[iv5].End(1).Column - 2)
- nrr = .[c6].resize(1, .[iv6].End(1).Column - 2)
- xrr = .[c7].resize(3, m)
- End With
- app.Visible = True
- xl.Close False: app.Quit
- Set xl = Nothing: Set app = Nothing
- For Each ar In xrr 'xrr的滤除号码整理为一维数组brr，以便使用filter
- If ar <> "" Then brr(k) = ar: k = k + 1
- Next
- k = 0
- For i = 1 To m '抽奖号码条件滤除
- If UBound(Filter(brr, arr(1, i))) < 0 Then s.Add arr(1, i), CStr(arr(1, i))
- Next
- Erase xrr: Set ar = Nothing: Erase arr: Erase brr 'Erase可代替Set= Nothing,但也不能用于变量
- j = 1 '抽奖序次初始化
- TextBox4.Text = "三等奖" '抽奖界面初始化
- Me.Shapes("TextBox 14").Visible = True '可以用me替代ActivePresentation.Slides(1),好爽!
- Me.Shapes("TextBox 15").Visible = True
- Me.Shapes("TextBox 16").Visible = True
- Me.Shapes("TextBox 17").Visible = True
- Me.Shapes("TextBox 14").TextFrame.TextRange.Text = "三等奖"
- Me.Shapes("TextBox 15").TextFrame.TextRange.Text = "二等奖"
- Me.Shapes("TextBox 16").TextFrame.TextRange.Text = "一等奖"
- Me.Shapes("TextBox 17").TextFrame.TextRange.Text = "特等奖"
- End If
- f = False
- If Me.CommandButton1.Caption = "停止" Then
- Me.CommandButton1.Caption = "开始"
- f = True
- Else
- Me.CommandButton1.Caption = "停止"
- If j < 5 Then n = --Mid(3321, j, 1) Else n = 0 '抽取各奖等的个数；抽取特别奖置0
- Do
- If f Then
- Select Case j '操作汇奖区
- Case 1
- Me.TextBox5.Text = temp(0) & " " & temp(1) & " " & temp(2)
- Me.TextBox5.Visible = True
- jt = "三等奖 " & TextBox5.Text
- Sleep 80 '延时让抽中号码有机会显示在抽奖区,而非一闪而过飘到汇奖区;调试时可改为800观察
- Me.TextBox1.Text = "" '注意加me,因为slide7也有TextBox;否则会出现清除失效!
- Me.TextBox2.Text = ""
- Me.TextBox3.Text = ""
- Case 2
- Me.TextBox6.Text = temp(0) & " " & temp(1) & " " & temp(2)
- Me.TextBox6.Visible = True
- jt = "二等奖 " & TextBox6.Text & vbCrLf & jt
- Sleep 80
- Me.TextBox1.Text = ""
- Me.TextBox2.Text = ""
- Me.TextBox3.Text = ""
- Case 3
- Me.TextBox7.Text = temp(0) & " " & temp(1)
- Me.TextBox7.Visible = True
- jt = "一等奖 " & TextBox7.Text & vbCrLf & jt
- Sleep 80
- Me.TextBox1.Text = ""
- Me.TextBox3.Text = ""
- Case 4
- Me.TextBox8.Text = temp(0)
- Me.TextBox8.Visible = True
- jt = "特等奖 " & TextBox8.Text & vbCrLf & jt
- Sleep 80
- Me.TextBox2.Text = ""
- Case 5
- Me.Shapes("TextBox 14").TextFrame.TextRange.Text = "生产线员工奖"
- Me.Shapes("TextBox 14").Visible = True
- TextBox5.Text = temp
- jt = jt & vbCrLf & vbCrLf & "生产线员工奖 " & temp
- Sleep 80
- Me.TextBox2.Text = ""
- Me.TextBox4.Text = "办公室员工奖"
- Case 6
- Me.Shapes("TextBox 15").TextFrame.TextRange.Text = "办公室员工奖"
- Me.Shapes("TextBox 15").Visible = True
- TextBox6.Text = temp
- jt = jt & vbCrLf & "办公室员工奖 " & temp
- Sleep 80
- Me.TextBox2.Text = ""
- Me.TextBox4.Text = "老员工奖"
- Case 7
- Me.Shapes("TextBox 16").TextFrame.TextRange.Text = "老员工奖"
- Me.Shapes("TextBox 16").Visible = True
- TextBox7.Text = temp
- jt = jt & vbCrLf & "老员工奖 " & temp
- Sleep 80
- Me.TextBox2.Text = ""
- Me.TextBox4.Text = "新员工奖"
- Case 8
- Me.Shapes("TextBox 17").TextFrame.TextRange.Text = "新员工奖"
- Me.Shapes("TextBox 17").Visible = True
- Me.TextBox8.Text = temp
- jt = jt & vbCrLf & "新员工奖 " & temp
- Sleep 100
- Me.TextBox2.Text = ""
- End Select
- j = j + 1
- Select Case j
- Case 5
- MsgBox "按“确定”按钮,开始抽取特别奖！"
- Me.Shapes("副标题 2").TextFrame.TextRange.Text = "附加特别奖"
- Me.TextBox5.Text = "": Me.TextBox6.Text = "": Me.TextBox7.Text = "": Me.TextBox8.Text = ""
- Me.Shapes("TextBox 14").Visible = False: Me.Shapes("TextBox 15").Visible = False
- Me.Shapes("TextBox 16").Visible = False: Me.Shapes("TextBox 17").Visible = False
- TextBox4.Text = "生产线员工奖"
- Set s = Nothing '集合s抽取特别奖时不需
- Case 9 '抽奖结束
- SlideShowWindows(1).View.Next
- Slide7.Shapes("Text Box 6").TextFrame.TextRange.Text = jt
- j = 0
- Me.Shapes("副标题 2").TextFrame.TextRange.Text = "幸运大抽奖活动"
- Me.TextBox4.Text = "": Me.TextBox5.Text = "": Me.TextBox6.Text = "": Me.TextBox7.Text = "": Me.TextBox8.Text = ""
- Me.Shapes("TextBox 14").Visible = False: Me.Shapes("TextBox 15").Visible = False
- Me.Shapes("TextBox 16").Visible = False: Me.Shapes("TextBox 17").Visible = False
- ScreenUpdating = True
- Exit Sub
- Case 2 To 4
- For i = 0 To n - 1
- s.Remove (temp(i)) '滤除已抽取号码
- Next
- Me.TextBox4.Text = Mid("三二一特", j, 1) & "等奖" '显示待抽的下一奖等
- End Select
- Exit Do '退出快闪循环准备下一轮抽奖
- Else
- If n Then
- temp = choose(s.Count, n) 's.count意味着已扣减抽取的样本
- For i = 0 To n - 1 '由于temp抽取的序号并未排序，s.remove时可能会造成s(--temp(i))中当时序标--temp(i)的变动和丢失，故在remove之前存好s(--temp(i)),而非存序号
- temp(i) = s(--temp(i)) & "" 'choose作为字典的key已置为文本
- Next
- Select Case n '下框的抽奖区即时显示具体抽中号码
- Case 3
- Me.TextBox1.Visible = True '因上次抽特等奖时将其隐藏
- Me.TextBox3.Visible = True
- Me.TextBox1.Text = temp(0): Me.TextBox2.Text = temp(1): Me.TextBox3.Text = temp(2)
- Case 2
- Me.TextBox1.Text = temp(0): Me.TextBox3.Text = temp(1)
- Me.TextBox2.Visible = False
- Case 1
- Me.TextBox1.Visible = False: Me.TextBox2.Visible = True: Me.TextBox3.Visible = False
- Me.TextBox2.Text = temp(0)
- End Select
- Else
- Randomize
- Select Case j '下框的抽奖区即时显示特别奖具体抽中号码
- Case 5
- temp = prr(1, Int(Rnd * UBound(prr, 2)) + 1)
- Me.TextBox2.Text = temp
- Case 6
- temp = frr(1, Int(Rnd * UBound(frr, 2)) + 1)
- Me.TextBox2.Text = temp
- Case 7
- temp = orr(1, Int(Rnd * UBound(orr, 2)) + 1)
- Me.TextBox2.Text = temp
- Case 8
- temp = nrr(1, Int(Rnd * UBound(nrr, 2)) + 1)
- Me.TextBox2.Text = temp
- End Select
- End If
- End If
- Sleep 30
- DoEvents
- Loop
- End If
- End Sub
- Function choose(m%, n%) '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
复制代码 |
|
