ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: ccyan3

PPT抽奖程序

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-9-25 17:31 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 hhjjpp 于 2016-9-25 20:59 编辑

尚有瑕疵,中奖事宜事关重大,应以此为准:

依次逐等抽奖并集中抽奖结果-h.rar

75.34 KB, 下载次数: 201

TA的精华主题

TA的得分主题

发表于 2016-9-29 16:38 | 显示全部楼层
本帖最后由 hhjjpp 于 2016-10-1 08:30 编辑

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

依次逐等抽奖并集中抽奖结果-h.rar

55 KB, 下载次数: 136

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2016-10-4 21:12 | 显示全部楼层

TA的精华主题

TA的得分主题

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

依次逐等抽奖并集中抽奖结果--h.rar

73.93 KB, 下载次数: 100

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-16 23:14 | 显示全部楼层
hhjjpp 发表于 2016-12-4 10:29
删除集合元素代码有误,特此纠正:

谢谢大侠!学习了    好作品

TA的精华主题

TA的得分主题

发表于 2016-12-17 15:12 | 显示全部楼层
本帖最后由 hhjjpp 于 2016-12-17 16:51 编辑
ccyan3 发表于 2016-12-16 23:14
谢谢大侠!学习了    好作品

只是附件界面丑了点,终于抽时间改了:
http://club.excelhome.net/thread-1314943-3-1.html
121758vdq1gvmtnmh8nmu1.jpg

限制性抽奖并汇集抽奖结果-h.rar

77.38 KB, 下载次数: 128

限制性抽奖设置-h.rar

14.33 KB, 下载次数: 108

TA的精华主题

TA的得分主题

发表于 2016-12-17 15:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
hhjjpp 发表于 2016-12-17 15:12
只是附件界面丑了点,终于抽时间改了:
http://club.excelhome.net/thread-1314943-3-1.html

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

TA的精华主题

TA的得分主题

发表于 2016-12-17 16:36 | 显示全部楼层
weiyingde 发表于 2016-12-17 15:47
又修改了,见完美之作。
有空琢磨一下。
大侠令人佩服,ppt接触时间之短,进步之快,令人汗颜。

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

TA的精华主题

TA的得分主题

发表于 2016-12-17 16:42 | 显示全部楼层
slide对象和ActiveWindow.Selection对象之下sliderange集合又是个什么关系?也一直没弄明白,总之ppt的对象层级关系都是稀里糊涂的!

TA的精华主题

TA的得分主题

发表于 2016-12-17 17:45 | 显示全部楼层
hhjjpp 发表于 2016-12-17 16:36
太过奖了,只是一点表面功夫而已!
我一直没搞明白slide对象之间的关系,图1编辑窗口左侧显示有两页幻灯 ...

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

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 18:40 , Processed in 0.059458 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表