用VBA在PowerPoint中实现日期时间秒级动态显示
【1 功能】
在PPT任意位置，动态显示当前日期、小时-分钟-秒、计时器。
PPT本身无此功能。
【2 使用方法】
下载下列模板PPT文件，按模板文件中的说明插入你的幻灯片即可。
【3 代码】
'*********************************************************** 使用说明 *********************************************************
'把此文本写入PowerPoint的VBA的宏里面，然后把PPT保存为PPT的ppam文件，在PPT“开发工具”里加载项中添加该ppam文件。
'PowerPoint需要的设置：
' 1、文件/选项/信任中心/信任中心设置/启用所有宏。
' 2、开发工具/加载项/添加，加入上述ppam文件。
'以后，只要在某个幻灯片中插入文本框TimeText，那么该文本框就会显示当前日期时间。
'*******************************************************************************************************************************
'***************** 定义与声明 ****************
#If VBA7 Or Win64 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal 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 temp As Shape
Public ID As Integer
Public SlideNO As Integer
'***************** 计时器 ********************
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
temp.TextFrame.TextRange.Text = Format(Date, "YYYY.MM.DD") & " " & Format(Time, "HH:MM:SS")
End Sub
'************* 放映时显示日期时间 **************
Public Sub OnSlideShowPageChange()
SlideNO = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
If Not ActivePresentation.Slides(SlideNO).Shapes("TimeText") Is Nothing Then
If ID > 0 Then
temp.TextFrame.TextRange.Text = ""
tt = KillTimer(0, ID)
ID = 0
End If
If ID <= 0 Then
ID = SetTimer(win_hwnd, 1000, 1000, AddressOf TimerProc)
Set temp = ActivePresentation.Slides(SlideNO).Shapes("TimeText")
temp.ZOrder (msoBringToFront)
temp.TextFrame.TextRange.Text = ""
Else
temp.TextFrame.TextRange.Text = ""
End If
End If
End Sub
'************** 结束放映时处理 ****************
Public Sub OnSlideShowTerminate()
tt = KillTimer(0, ID)
ID = 0
ActivePresentation.Saved = msoTrue
End Sub
