ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 自动加载宏实现的演讲倒计时,想看源代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-3-15 00:01 | 显示全部楼层 |阅读模式
这是一个加载宏,可以实现倒计时功能。我很想学习,可惜与作者联系不上,不知有没有高手帮忙看一下。

自动加载宏实现的演讲倒计时-叶鹏.rar

12.45 KB, 下载次数: 230

TA的精华主题

TA的得分主题

发表于 2016-4-23 16:22 | 显示全部楼层
回复我,就能看到代码。

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-4-27 09:43 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-4-30 07:45 | 显示全部楼层

  1. 'CTimer类模块:
  2. '申明API函数
  3. Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  4. Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

  5. Private TimerID As Long

  6. Public WithEvents thisApp As Application

  7. Private Sub thisApp_SlideShowBegin(ByVal Wn As SlideShowWindow)
  8.     Dim prompt As String
  9.     prompt = "   演讲时间以分钟为单位,最长不超过300分钟。" _
  10.     & vbCrLf & "        无意义输入,视同取消。" _
  11.     & vbCrLf _
  12.     & vbCrLf & "             叶鹏" _
  13.     & vbCrLf & "        yehpeng@sohu.com" _
  14.     & vbCrLf & "        宁波职业技术学院" _
  15.     & vbCrLf & "         2006年10月11日"
  16.     Duration = Val(InputBox(prompt, "演讲倒计时", "45"))
  17.    
  18.     '将演讲时间单位转换为秒
  19.     If Duration <= 0 Then
  20.         Exit Sub
  21.         'Duration = 45 * 60
  22.     ElseIf Duration > 300 Then
  23.         Duration = 300 * 60
  24.     Else
  25.         Duration = Duration * 60
  26.     End If
  27.       
  28.      '在母板上添加一个文本框,用以显示时间;该文本在结束放映时被删除。
  29.     Dim txtShowTime As Shape
  30.     Set txtShowTime = ActivePresentation.SlideMaster.Shapes.AddTextbox(msoTextOrientationHorizontal, ActivePresentation.SlideMaster.Width - 100, 10, 110, 40)
  31.     '设置该文本框的Name属性
  32.     txtShowTime.Name = "Timer"
  33.     '设置该文本框的文本格式
  34.     txtShowTime.TextFrame.TextRange.Text = "倒计时"
  35.     With txtShowTime.TextFrame.TextRange.Font
  36.         .Name = "New Time Roman"
  37.         .Size = 20
  38.         .Bold = msoTrue
  39.         .Color.RGB = RGB(255, 50, 0)
  40.     End With
  41.         
  42.     '创建定时器,触发时间为1秒,到时执行TimerProc过程
  43.     TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
  44.     If TimerID = 0 Then
  45.         ActivePresentation.SlideMaster.Shapes("Timer").Delete
  46.         MsgBox "由于系统原因,不能创建定时器!"
  47.         Exit Sub
  48.     End If
  49.    
  50. End Sub

  51. Private Sub thisApp_SlideShowEnd(ByVal Pres As Presentation)
  52.    If TimerID <> 0 Then
  53.         '终止定时器
  54.         TimerID = KillTimer(0, TimerID)
  55.         '删除时间显示文本框
  56.         ActivePresentation.SlideMaster.Shapes("Timer").Delete
  57.    End If   
  58. End Sub
复制代码


  1. 'modAutoMacro模块:
  2. Public thisPPT As New CTimer
  3. Public Duration As Long  '演讲时间

  4. Sub Auto_Open()
  5.    
  6.     ' 启动PowerPoint时可以自动运行的宏
  7.     Set thisPPT.thisApp = Application
  8.    
  9. End Sub
  10. Sub Auto_Close()
  11.    
  12.     ' 关闭PowerPoint时可以自动运行的宏
  13.     Set thisPPT.thisApp = Nothing
  14.    
  15. End Sub

  16. '定时器到时的时候要执行的过程
  17. Public Sub TimerProc()
  18.    
  19.     'DoEvents
  20.    
  21.     '剩余的秒数
  22.     Duration = Duration - 1
  23.     '将剩余的秒数转换为"时:分:秒"的格式
  24.     '小时数
  25.     h = Int(Duration / 3600)
  26.         
  27.     temp = Duration Mod 3600
  28.    
  29.     '分钟数
  30.     m = Int(temp / 60)
  31.     '秒数
  32.     s = temp Mod 60
  33.    
  34.     '函数TimeSerial将小时数、分钟数、秒数合并成时间格式
  35.    
  36.     If TimeSerial(h, m, s) <= TimeSerial(0, 0, 0) Then
  37.         '退出放映
  38.         ActivePresentation.SlideShowWindow.View.Exit
  39.     Else
  40.         '在文本框中显示时间
  41.         ActivePresentation.SlideMaster.Shapes("Timer").TextFrame.TextRange.Text = Format(TimeSerial(h, m, s), "hh:mm:ss")        
  42.     End If        
  43. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2016-4-30 07:47 | 显示全部楼层

  1. 'modAutoMacro模块:
  2. Public thisPPT As New CTimer
  3. Public Duration As Long  '演讲时间

  4. Sub Auto_Open()
  5.    
  6.     ' 启动PowerPoint时可以自动运行的宏
  7.     Set thisPPT.thisApp = Application
  8.    
  9. End Sub
  10. Sub Auto_Close()
  11.    
  12.     ' 关闭PowerPoint时可以自动运行的宏
  13.     Set thisPPT.thisApp = Nothing
  14.    
  15. End Sub

  16. '定时器到时的时候要执行的过程
  17. Public Sub TimerProc()
  18.    
  19.     'DoEvents
  20.    
  21.     '剩余的秒数
  22.     Duration = Duration - 1
  23.     '将剩余的秒数转换为"时:分:秒"的格式
  24.     '小时数
  25.     h = Int(Duration / 3600)
  26.         
  27.     temp = Duration Mod 3600
  28.    
  29.     '分钟数
  30.     m = Int(temp / 60)
  31.     '秒数
  32.     s = temp Mod 60
  33.    
  34.     '函数TimeSerial将小时数、分钟数、秒数合并成时间格式
  35.    
  36.     If TimeSerial(h, m, s) <= TimeSerial(0, 0, 0) Then
  37.         '退出放映
  38.         ActivePresentation.SlideShowWindow.View.Exit
  39.     Else
  40.         '在文本框中显示时间
  41.         ActivePresentation.SlideMaster.Shapes("Timer").TextFrame.TextRange.Text = Format(TimeSerial(h, m, s), "hh:mm:ss")        
  42.     End If        
  43. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2016-4-30 07:50 | 显示全部楼层
抱歉,我发了多次,帖子需要审核,第一部分,发不上去。

TA的精华主题

TA的得分主题

发表于 2016-4-30 08:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
我重新做了下,不是原来的了,你只看代码吧

自动加载宏2.zip

9.4 KB, 下载次数: 248

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-5-5 16:09 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
banjinjiu 发表于 2016-4-30 08:00
我重新做了下,不是原来的了,你只看代码吧

非常感谢,很好的学习材料,谢谢

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-5-5 16:10 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
yinhong7 发表于 2016-5-5 16:09
非常感谢,很好的学习材料,谢谢

home可能被攻击了,附件无法下载

TA的精华主题

TA的得分主题

发表于 2017-8-26 11:11 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
banjinjiu 发表于 2016-4-30 08:00
我重新做了下,不是原来的了,你只看代码吧

1、要用此含此标准模块和类模块的ppt做自己的ppt,或将此标准模块和类模块复制到自己的ppt中来
2、运行前得先运行一次Sub Auto_Open()
    ' 启动PowerPoint时可以自动运行的宏
    Set thisPPT.thisApp = Application
End Sub
要做成通用的得解决这两个问题才行,不然就得手动完成以上两步。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-28 17:58 , Processed in 0.060087 second(s), 14 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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