I created this VBA code with the help of Chatgpt back and forth, such that i can creata a LiveSplit looking slide inside my powerpoint for a theatre piece, where the actor speedruns the 7 stages of grief (in swedish).

But my code runs super laggy and wont update every 0.1 seconds. What is wrong, is there a refresh rate for powerpoint or is it some other issue?

Option Explicit

' =========================
' HIGH RES TIMER API
' =========================
#If VBA7 Then
    Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#Else
    Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#End If

' =========================
' GLOBALS
' =========================
Private freq As Currency
Private startCounter As Currency
Private nowCounter As Currency

Public TimerRunning As Boolean

' TOTAL
Private totalStart As Currency

' STAGES (start times)
Private stageStart(1 To 7) As Currency

' STAGE TIMES (frozen values)
Private stageTime(1 To 7) As Double

Private currentStage As Integer

' =========================
' RESET EVERYTHING
' =========================
Sub ResetAll()

    TimerRunning = False
    currentStage = 0

    Dim i As Integer
    For i = 1 To 7
        stageTime(i) = 0
    Next i

End Sub

' =========================
' START (RESET + STAGE 1 + TOTAL)
' =========================
Sub StartStage1()

    ResetAll

    QueryPerformanceFrequency freq
    QueryPerformanceCounter startCounter

    totalStart = startCounter

    currentStage = 1
    stageStart(1) = startCounter

    TimerRunning = True

    RunTimers

End Sub

' =========================
' NEXT STAGE
' =========================
Sub NextStage()

    If Not TimerRunning Then Exit Sub
    If currentStage >= 7 Then Exit Sub

    QueryPerformanceCounter nowCounter

    ' freeze current stage
    stageTime(currentStage) = (nowCounter - stageStart(currentStage)) / freq

    ' move to next stage
    currentStage = currentStage + 1
    stageStart(currentStage) = nowCounter

End Sub

' =========================
' STOP ALL
' =========================
Sub StopStage1()
    TimerRunning = False
End Sub

Sub ResetAllTimers()

    Dim i As Integer
    Dim shp As Shape

    ' stop system
    TimerRunning = False
    currentStage = 0

    ' reset data
    For i = 1 To 7
        stageTime(i) = 0
    Next i

    ' reset total start
    totalStart = 0

    ' reset display shapes
    On Error Resume Next

    ' TOTAL
    Set shp = SlideShowWindows(1).View.Slide.Shapes("TotalTimer")
    shp.TextFrame.TextRange.Text = "-"

    ' STAGES
    For i = 1 To 7
        Set shp = SlideShowWindows(1).View.Slide.Shapes("Stage" & i & "Timer")
        shp.TextFrame.TextRange.Text = "-"
    Next i

    On Error GoTo 0

End Sub

' =========================
' MAIN LOOP
' =========================
Sub RunTimers()

    Dim shpT As Shape
    Dim shp(1 To 7) As Shape

    Dim trT As TextRange
    Dim tr(1 To 7) As TextRange

    Dim i As Integer

    On Error Resume Next

    Set shpT = SlideShowWindows(1).View.Slide.Shapes("TotalTimer")

    For i = 1 To 7
        Set shp(i) = SlideShowWindows(1).View.Slide.Shapes("Stage" & i & "Timer")
    Next i

    On Error GoTo 0

    If shpT Is Nothing Then
        MsgBox "Missing TotalTimer shape"
        TimerRunning = False
        Exit Sub
    End If

    For i = 1 To 7
        If shp(i) Is Nothing Then
            MsgBox "Missing Stage" & i & "Timer shape"
            TimerRunning = False
            Exit Sub
        End If
    Next i

    Set trT = shpT.TextFrame.TextRange
    For i = 1 To 7
        Set tr(i) = shp(i).TextFrame.TextRange
    Next i

    Do While TimerRunning

        QueryPerformanceCounter nowCounter

        ' =====================
        ' TOTAL TIMER
        ' =====================
        Dim totalTime As Double
        totalTime = (nowCounter - totalStart) / freq

        trT.Text = FormatTime(totalTime)

        ' =====================
        ' STAGES
        ' =====================
        For i = 1 To 7

            If i < currentStage Then
                ' already completed ? frozen
                tr(i).Text = FormatTime(stageTime(i))

            ElseIf i = currentStage Then
                ' active stage ? live timer
                tr(i).Text = FormatTime((nowCounter - stageStart(i)) / freq)

            Else
                ' future stages
                tr(i).Text = "-"
            End If

        Next i

        DoEvents

    Loop

End Sub

' =========================
' FORMAT TIME
' =========================
Function FormatTime(seconds As Double) As String

    Dim mins As Long
    Dim secs As Long
    Dim tenths As Long

    mins = Int(seconds / 60)
    secs = Int(seconds Mod 60)
    tenths = Int((seconds - Int(seconds)) * 10)

    ' =========================
    ' SMART DISPLAY RULES
    ' =========================

    If mins = 0 Then
        ' under 1 min ? SS.t
        FormatTime = secs & "." & tenths
    Else
        ' 1 min+ ? MM:SS.t
        FormatTime = mins & ":" & Right$("00" & secs, 2) & "." & tenths
    End If

End Function

Regards.