关于控制计划的请教

popbird2024

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