wen_jf
发表于 2017-2-6 19:46:04
[*]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 appAs 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 = ..End(1).Column - 2
[*] arr = ..resize(1, m)
[*] prr = ..resize(1, ..End(1).Column - 2)
[*] frr = ..resize(1, ..End(1).Column - 2)
[*] orr = ..resize(1, ..End(1).Column - 2)
[*] nrr = ..resize(1, ..End(1).Column - 2)
[*] xrr = ..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
复制代码
defnrgw
发表于 2017-2-6 20:25:34
孜孜以求，不断完美，中见巅峰大作。再用更新，收入囊中，以备后用。谢谢了。
lennylau
发表于 2017-2-6 20:37:15
少了与之连用的“限制性抽奖设置-h.xls“文件，测试无法进行。
annylii
发表于 2017-2-6 20:42:23
是我疏漏！
花仙子岩
发表于 2017-2-6 20:57:41
测试可以，只是刷新较慢，有撤屏卡顿之感，若完善一下更好
saventang
发表于 2017-7-7 16:33:28
感谢分享。
hhm321
发表于 2017-9-19 09:36:38
学习了，不错
Edigeshena
发表于 2019-1-9 09:14:15
这个好这个真好:loveliness:
caac03
发表于 2019-1-9 22:39:13
学习学习高手
虚假的繁荣清泉
发表于 2019-2-12 14:20:53
高手啊，厉害