自动加载宏实现的演讲倒计时，想看源代码

yinhong7

这是一个加载宏，可以实现倒计时功能。我很想学习，可惜与作者联系不上，不知有没有高手帮忙看一下。

banjinjiu

回复我，就能看到代码。

yinhong7

banjinjiu 发表于 2016-4-23 16:22
回复我，就能看到代码。

我信你呢，请大神多多指教

banjinjiu

一

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

复制代码

二

1. 'modAutoMacro模块：
   
2. Public thisPPT As New CTimer
   
3. Public Duration As Long  '演讲时间
   
4. 
   
5. Sub Auto_Open()
   
6.    
   
7.     ' 启动PowerPoint时可以自动运行的宏
   
8.     Set thisPPT.thisApp = Application
   
9.    
   
10. End Sub
    
11. Sub Auto_Close()
    
12.    
    
13.     ' 关闭PowerPoint时可以自动运行的宏
    
14.     Set thisPPT.thisApp = Nothing
    
15.    
    
16. End Sub
    
17. 
    
18. '定时器到时的时候要执行的过程
    
19. Public Sub TimerProc()
    
20.    
    
21.     'DoEvents
    
22.    
    
23.     '剩余的秒数
    
24.     Duration = Duration - 1
    
25.     '将剩余的秒数转换为"时：分：秒"的格式
    
26.     '小时数
    
27.     h = Int(Duration / 3600)
    
28.         
    
29.     temp = Duration Mod 3600
    
30.    
    
31.     '分钟数
    
32.     m = Int(temp / 60)
    
33.     '秒数
    
34.     s = temp Mod 60
    
35.    
    
36.     '函数TimeSerial将小时数、分钟数、秒数合并成时间格式
    
37.    
    
38.     If TimeSerial(h, m, s) <= TimeSerial(0, 0, 0) Then
    
39.         '退出放映
    
40.         ActivePresentation.SlideShowWindow.View.Exit
    
41.     Else
    
42.         '在文本框中显示时间
    
43.         ActivePresentation.SlideMaster.Shapes("Timer").TextFrame.TextRange.Text = Format(TimeSerial(h, m, s), "hh:mm:ss")        
    
44.     End If        
    
45. End Sub

复制代码

banjinjiu

二

1. 'modAutoMacro模块：
   
2. Public thisPPT As New CTimer
   
3. Public Duration As Long  '演讲时间
   
4. 
   
5. Sub Auto_Open()
   
6.    
   
7.     ' 启动PowerPoint时可以自动运行的宏
   
8.     Set thisPPT.thisApp = Application
   
9.    
   
10. End Sub
    
11. Sub Auto_Close()
    
12.    
    
13.     ' 关闭PowerPoint时可以自动运行的宏
    
14.     Set thisPPT.thisApp = Nothing
    
15.    
    
16. End Sub
    
17. 
    
18. '定时器到时的时候要执行的过程
    
19. Public Sub TimerProc()
    
20.    
    
21.     'DoEvents
    
22.    
    
23.     '剩余的秒数
    
24.     Duration = Duration - 1
    
25.     '将剩余的秒数转换为"时：分：秒"的格式
    
26.     '小时数
    
27.     h = Int(Duration / 3600)
    
28.         
    
29.     temp = Duration Mod 3600
    
30.    
    
31.     '分钟数
    
32.     m = Int(temp / 60)
    
33.     '秒数
    
34.     s = temp Mod 60
    
35.    
    
36.     '函数TimeSerial将小时数、分钟数、秒数合并成时间格式
    
37.    
    
38.     If TimeSerial(h, m, s) <= TimeSerial(0, 0, 0) Then
    
39.         '退出放映
    
40.         ActivePresentation.SlideShowWindow.View.Exit
    
41.     Else
    
42.         '在文本框中显示时间
    
43.         ActivePresentation.SlideMaster.Shapes("Timer").TextFrame.TextRange.Text = Format(TimeSerial(h, m, s), "hh:mm:ss")        
    
44.     End If        
    
45. End Sub

复制代码

banjinjiu

抱歉，我发了多次，帖子需要审核，第一部分，发不上去。

banjinjiu

我重新做了下，不是原来的了，你只看代码吧

yinhong7

banjinjiu 发表于 2016-4-30 08:00
我重新做了下，不是原来的了，你只看代码吧

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

yinhong7

yinhong7 发表于 2016-5-5 16:09
非常感谢，很好的学习材料，谢谢

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

leikaiyi123

banjinjiu 发表于 2016-4-30 08:00
我重新做了下，不是原来的了，你只看代码吧

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