Nedtælling der fortsætter på næste side

Hvordan har du lavet din aktuelle timer?

Jeg har forfattet en VBA kode som kan løse din udfordring, men har du anvendt en anden metode, kan det være det er lettere at bygge videre på den.

Skriv lige hvordan du har løst den hidtil, og om løsningen herunder er det du ledte efter.

;0)

Here goes:

Sub testtimer()
' Kode til at vise timer i slides

' Kan være den ikke kører præcis på sekundet

' Kræver alle slides som skal vise timer
' har en figur med navnet Timer

' Navn angives ved at vælge fanen Hjem,
' knappen er længst til højre!
' DK: Hjem, Marker, Valgrude...
' UK: Home, Select, Selection Pane...
' marker figuren, og rediger navnet i Valgrude/Selection Pane
' Efter figuren er navngivet, kan den kopieres ind i andre dias,
' den beholder navnet

' koden stopper efter datMaxTime, eller når præsentationen lukkes

Dim datTime As Date
Dim intCounter As Integer
Dim intCurrentSlide As Integer
Dim intPreviousSlide As Integer
Dim datMaxTime As Date

On Error GoTo errHandling

' her indstilles max køretid til 2 timer
datMaxTime = DateAdd("m", 120, Now)


intCounter = 15 ' antal sekunder til nedtælling
datTime = DateAdd("s", intCounter, Now)
Restart:
Do Until datMaxTime < Now
DoEvents
' Denne anvendes for at køre i PowerPoint Designvisningen:
' intCurrentSlide = ActivePresentation.Windows(1).View.Slide.SlideIndex
   
' Denne anvendes for at køre i PowerPoint DiasShow visning:
intCurrentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
   
If intCurrentSlide > intPreviousSlide Then
  Select Case intCurrentSlide
  Case 3 ' indsæt diasnummer som skal have ny tid, her dias 3
    datTime = DateAdd("s", 30, Now) ' indstil ny tid 30 sek
  Case 5 ' her dias 5
    datTime = DateAdd("s", 40, Now) 'her 40 sek
    ' tilføj flere Case DiasNr efter behov!
  End Select
End If
With ActivePresentation.Slides(intCurrentSlide)
  .Shapes("Timer").TextFrame.TextRange.Text = _
          Format(datTime - Now, "hh:mm:ss") & " - " & intCurrentSlide
End With
intPreviousSlide = intCurrentSlide
Loop


errHandling:
If Err.Number <> 0 Then
Select Case Err.Number
  Case -2147188160
  Resume ExitSubHere
  Case Else
  Debug.Print Err.Number
  MsgBox Err.Number & vbCr & Err.Description
End Select
Else
  GoTo Restart ' hvis ingen fejl start over
End If

ExitSubHere:
End Sub

Tak for hjælpen :) og beklager meget det sene svar.