Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
Public UpdateShapes As Collection
Public TimerID As Long
Sub StartTimer()
If TimerID = 0 Then
TimerID = SetTimer(0, 0, 1000, AddressOf UpdateTimer)
Debug.Print "StartTimer ID:" & TimerID
End If
End Sub
Sub StopTimer()
KillTimer 0, TimerID
Debug.Print "StopTimer ID:" & TimerID
TimerID = 0
End Sub
Sub UpdateTimer()
Dim currentTime As Date
currentTime = Now
For Each shape In UpdateShapes
If shape.Name = "Clock_Hour" Then
shape.Rotation = (Hour(currentTime) Mod 12) * 30 + Minute(currentTime) / 2 - 90
ElseIf shape.Name = "Clock_Minute" Then
shape.Rotation = Minute(currentTime) * 6 + Second(currentTime) / 10 - 90
ElseIf shape.Name = "Clock_Second" Then
shape.Rotation = Second(currentTime) * 6 - 90
ElseIf Mid(shape.Name, 1, 10) = "TimerText_" Then
Dim formatStr As String
formatStr = Trim(Mid(shape.Name, 11, 10000))
If Len(formatStr) = 0 Then
formatStr = "yyyy-mm-dd hh:mm:ss"
End If
shape.TextFrame.TextRange.Text = format(Now, formatStr) '不知道为什么对母版进行此处更改不会更新到放映窗口，所以需要下面一行代码帮助更新
shape.Rotation = shape.Rotation '更新放映窗口
End If
Next shape
End Sub
Sub OnSlideShowPageChange()
Dim currentPlaySlide As slide
Set currentPlaySlide = Application.SlideShowWindows(1).View.slide
Dim timerShapes As New Collection
Set timerShapes = FindShapesInSlide(currentPlaySlide)
Set UpdateShapes = timerShapes
If UpdateShapes.Count > 0 Then
Call StartTimer
Else
Call StopTimer
End If
End Sub
Sub OnSlideShowTerminate()
Call StopTimer
End Sub
Sub Test()
Set currentPlaySlide = Application.ActiveWindow.View.slide
currentPlaySlide.shapes.AddTextbox msoTextOrientationHorizontal, 10, 10, 200, 50
End Sub
Sub 插入拟态表盘()
Dim oSlide As Variant
Dim oShape As shape
Dim shapes As New Collection
Dim x As Single, y As Single, radius As Single, length As Single, Count As Single, angle
Set oSlide = Application.ActiveWindow.View.slide
x = 200
y = 200
radius = 100
length = 5
Count = 60
Dim linesGroup As New Collection, numberGroup As New Collection
For I = 0 To Count - 1
angle = -I * (360 / Count) * (3.1415926 / 180) + 3.1415926 / 3
If I Mod 5 = 0 Then
'生成粗线
Set oShape = oSlide.shapes.AddLine(x + radius * Cos(angle), y - radius * Sin(angle), x + (radius - length * 1.5) * Cos(angle), y - (radius - length * 1.5) * Sin(angle))
oShape.Line.Weight = 2
linesGroup.Add oShape.Name
'生成数字
Set oShape = oSlide.shapes.AddTextbox(msoTextOrientationHorizontal, x + (radius * 0.9 - length * 1.5) * Cos(angle) - 13, y - (radius * 0.9 - length * 1.5) * Sin(angle) - 14, 38, 20)
oShape.TextFrame.TextRange.Text = CStr(I / 5 + 1)
numberGroup.Add oShape.Name
Else
'生成细线
Set oShape = oSlide.shapes.AddLine(x + radius * Cos(angle), y - radius * Sin(angle), x + (radius - length) * Cos(angle), y - (radius - length) * Sin(angle))
oShape.Line.Weight = 1
linesGroup.Add oShape.Name
End If
Next
'将刻度线打组
Set oShape = oSlide.shapes.Range(CollectionToArray(linesGroup)).group
oShape.Name = "LinesGroup"
shapes.Add oShape.Name
'将数字打组
Set oShape = oSlide.shapes.Range(CollectionToArray(numberGroup)).group
oShape.Name = "NumberGroup"
shapes.Add oShape.Name
Dim showShape As shape, hideShape As shape, oGroup As shape
'生成时针
Set showShape = oSlide.shapes.AddLine(x, y, x + radius * 0.5, y)
showShape.Line.Weight = 4
showShape.Line.ForeColor.RGB = RGB(0, 0, 0)
Set hideShape = oSlide.shapes.AddLine(x, y, x - radius * 0.5, y)
hideShape.Visible = msoFalse
Set oGroup = oSlide.shapes.Range(Array(showShape.Name, hideShape.Name)).group
oGroup.Name = "Clock_Hour"
shapes.Add oGroup.Name
'生成分针
Set showShape = oSlide.shapes.AddLine(x, y, x + radius * 0.7, y)
showShape.Line.Weight = 2
showShape.Line.ForeColor.RGB = RGB(0, 0, 0)
Set hideShape = oSlide.shapes.AddLine(x, y, x - radius * 0.7, y)
hideShape.Visible = msoFalse
Set oGroup = oSlide.shapes.Range(Array(showShape.Name, hideShape.Name)).group
oGroup.Name = "Clock_Minute"
shapes.Add oGroup.Name
oGroup.Rotation = 100
'生成秒针
Set showShape = oSlide.shapes.AddLine(x, y, x + radius * 0.9, y)
showShape.Line.Weight = 1
showShape.Line.ForeColor.RGB = RGB(255, 0, 0)
Set hideShape = oSlide.shapes.AddLine(x, y, x - radius * 0.9, y)
hideShape.Visible = msoFalse
Set oGroup = oSlide.shapes.Range(Array(showShape.Name, hideShape.Name)).group
oGroup.Name = "Clock_Second"
shapes.Add oGroup.Name
oGroup.Rotation = 200
'打总组
'Dim arr() As String
'arr = CollectionToArray(shapes)
'Set oShape = oSlide.shapes.Range(arr).group
'oShape.Name = "ClockGroup"
End Sub
Sub 插入时间()
Dim tb As shape
Set tb = Application.ActiveWindow.View.slide.shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 200, 50)
tb.Name = "TimerText_hh时mm分ss秒"
tb.TextFrame.TextRange.Text = format(Now, "hh时mm分ss秒")
End Sub
Sub 插入日期和时间()
Dim tb As shape
Set tb = Application.ActiveWindow.View.slide.shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 400, 50)
tb.Name = "TimerText_yyyy年mm月dd日 hh时mm分ss秒"
tb.TextFrame.TextRange.Text = format(Now, "yyyy年mm月dd日 hh时mm分ss秒")
End Sub
Function FindShapesInSlide(oSlide As slide) As Collection
Dim result As New Collection
Dim currentPlaySlide As Object
Dim shapeInMaster As Object
Dim oShape As Variant
For Each oShape In oSlide.shapes
If Mid(oShape.Name, 1, 10) = "TimerText_" Or InStr("Clock_Hour,Clock_Minute,Clock_Second", oShape.Name) > 0 Then
result.Add oShape
End If
Next oShape
For Each oShape In oSlide.CustomLayout.shapes
If Mid(oShape.Name, 1, 10) = "TimerText_" Or InStr("Clock_Hour,Clock_Minute,Clock_Second", oShape.Name) > 0 Then
result.Add oShape
End If
Next oShape
Set FindShapesInSlide = result
End Function
Function CollectionToArray(col As Collection) As String()
Dim arr() As String
ReDim arr(1 To col.Count)
For I = 1 To col.Count
arr(I) = col(I)
Next
CollectionToArray = arr
End Function
页:
1
[2]