PPT的VBA宏计时器
2018-12-26 14:45阅读：
打开VBA编辑器，只需要插入一个 模块，复制如下代码即可，在PPT页面右下角显示计时；
#If VBA7 Or Win64Then
Declare
PtrSafe Function SetTimer Lib 'user32'
(ByValhwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As
Long, ByVal lpTimerFunc As LongPtr) As Long
Declare
PtrSafe Function KillTimer Lib
'user32' (ByValhwnd As Long, ByVal nIDEvent As Long) As
Long
#Else
Declare
Function SetTimer Lib 'user32' (ByVal
hwnd As Long, ByVal nIDEvent As Long, ByV
al uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Declare
Function KillTimer Lib 'user32' (ByVal
hwnd As Long, ByVal nIDEvent As Long) As Long
#End If
'
Public index As Integer
Public count As Integer
Public temp As Shape
Public ID As Integer
'
Public Sub
TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal
idEvent As Long, ByVal dwTime As Long)
count = count + 1
temp.TextFrame.TextRange.Text =
TimeSerial(count \ 3600, (count \ 60) Mod 60, count Mod 60)
'转为时间格式
End Sub
'
Public Sub
OnSlideShowPageChange()
If
ID <= 0 Then
ID = SetTimer(win_hwnd, 1000,
1000, AddressOf TimerProc)
Set temp =
ActivePresentation.Designs(1).SlideMaster.Shapes.AddTextbox(msoTextOrientationHorizontal,
ActivePresentation.PageSetup.SlideWidth - 70,
ActivePresentation.PageSetup.SlideHeight - 20, 75, 25)
'
'temp.Name =
'Time'
temp.ZOrder
(msoBringToFront)
Withtemp.TextFrame.TextRange
.Font.Name = 'Arial' '文本框字体
.Font.Size = 12
'文本框字体大小
.Text = '0:00:00'
'文本框文字
End With
Else
temp.TextFrame.TextRange.Text
= ''
End
If
End Sub
'
Public Sub
OnSlideShowTerminate()
tt = KillTimer(0, ID)
temp.Delete
count = 0
ID = 0
End Sub
