Scores bijhouden tijdens Quizavond in PowerPoint

[MagicianB]

Hallo,

We zijn drukdoende met een Quiz voor oudjaar en tijdens deze quiz willen we de scores bijhouden.
De quiz wordt gepresenteerd dmv PowerPoint.

Er zullen 4 teams zijn, en we willen de scores live bijhouden in dezelfde Powerpoint.

Het liefste zou ik dit doen door middel van knoppen waarop geklikt kan worden en er dan 1 punt bij de huidige score van dat team wordt opgeteld.

Dus de powerpoint draaiende en onderaan een balkje met daarin: team1, team2, team3, team4, waarop je kunt klikken.

Is dit mogelijk met powerpoint, of door middel van macro's?

Alvast bedankt voor de hulp!

 

[DJJochem]

Heb je toevallig Buzzers voor de playstation?

 

[MagicianB]

Hoi Jochem,

Nee we hebben niet de buzzers van de playstation.
Wat we wel hebben is gewoon een Quiz-systeem.
Dit zijn eigen gemaakte kastjes met lampjes erin en één drukknop op elk kastje.
Elk team krijgt zo'n kastje, en alleen het lampje van het eerste team dat reageerd gaat branden en blijft branden.

In principe is de eerste vraag dus of er een mogelijkheid bestaat binnen PowerPoint om scores bij te houden per team met een hotkey of klik met de muis.
Wanneer dit niet mogelijk is, bestaat er dan een andere mogelijkheid om zoiets te maken als programmatje?

 

[DJJochem]

Jammer.
Met de buzzers is er namelijk een stukje gratis software om prachtige quizzen te maken.
Maar goed, misschien als je effe googlet, dat je dan wat verder komt?
Zoek naar Quiz software.

 

[MagicianB]

Ben inmiddels in Excel begonnen met Visual Basic en Macro's toekennen, en het lukt al heel goed.
Toch bedankt voor het meedenken!

 

[DJJochem]

Fijn dat het gelukt is.
Als het af is en werkt, zou je dan de Macro's en VB codes kunnen posten?
Ben wel geïnteresseerd in je macro.
Desnoods in het Test mijn programma subforum hier op Helpmij.

 

[MagicianB]

Hieronder de lap VB code.
Heb erbij gezet waarvoor het dient.

Ik ga het nog verder uitwerken vwb plaatjes en geluidjes.
Maar heb in basis alle functies werkend.
Dus het idee is aparte rondes te hebben tijdens te avond waarin punten te verdienen zijn.
De punten worden na elke ronde weggeschreven door op de einde ronde button te klikken.
De totaalscore kan opgehaald worden door op totaalscore te klikken.
Hotkeys 1 2 3 4 en CTRL+1 CTRL+2 CTRL+3 CTRL+4 zijn bedoeld voor de puntentelling.
Ook kan elk apart team zijn punten verliezen door op de reset knop onder elk team te klikken.
Ook is er nog een globale resetknop.

Bekijk de code maar eens en graag op/aanmerkingen, waar dit mijn eerste keer was in VBA programmeertaal zullen er genoeg fouten in staan.




Declare Function sndPlaySound32 Lib "winmm.dll" Alias _
"sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
'Team1 1 punt erbij
Sub team1plus()
team1 = Range("A1") + 1
Range("A1") = team1
End Sub
'Team2 1 punt erbij
Sub team2plus()
team2 = Range("E1") + 1
Range("E1") = team2
End Sub
'Team3 1 punt erbij
Sub team3plus()
team3 = Range("I1") + 1
Range("I1") = team3
End Sub
'Team4 1 punt erbij
Sub team4plus()
team4 = Range("M1") + 1
Range("M1") = team4
End Sub
'Team1 1 punt eraf
Sub team1min()
team1 = Range("A1") - 1
Range("A1") = team1
End Sub
'Team2 1 punt eraf
Sub team2min()
team2 = Range("E1") - 1
Range("E1") = team2
End Sub
'Team3 1 punt eraf
Sub team3min()
team3 = Range("I1") - 1
Range("I1") = team3
End Sub
'Team4 1 punt eraf
Sub team4min()
team4 = Range("M1") - 1
Range("M1") = team4
End Sub
'Team1 reset
Sub team1reset()
team1 = Range("A1") - Range("A1")
Range("A1") = team1
End Sub
'Team2 reset
Sub team2reset()
team2 = Range("E1") - Range("E1")
Range("E1") = team2
End Sub
'Team3 reset
Sub team3reset()
team3 = Range("I1") - Range("I1")
Range("I1") = team3
End Sub
'Team4 reset
Sub team4reset()
team4 = Range("M1") - Range("M1")
Range("M1") = team4
End Sub
'Hotkeys voor bovenstaande routines
Sub Hotkey()
With Application
.OnKey Key:="1", Procedure:="team1plus"
.OnKey Key:="^1", Procedure:="team1min"
.OnKey Key:="2", Procedure:="team2plus"
.OnKey Key:="^2", Procedure:="team2min"
.OnKey Key:="3", Procedure:="team3plus"
.OnKey Key:="^3", Procedure:="team3min"
.OnKey Key:="4", Procedure:="team4plus"
.OnKey Key:="^4", Procedure:="team4min"
.OnKey Key:="j", Procedure:="geluid1"
End With
End Sub
'Globale reset
Sub team1234reset()
team1 = Range("A1") - Range("A1")
Range("A1") = team1
team2 = Range("E1") - Range("E1")
Range("E1") = team2
team3 = Range("I1") - Range("I1")
Range("I1") = team3
team4 = Range("M1") - Range("M1")
Range("M1") = team4
End Sub
Sub Totaalscore()
Dim emptyRow As Long

'Sheet 1 Activeren
Sheets(1).Activate

'Data naar cellen verplaatsen
Cells(1, 1).Value = Worksheets("Sheet2").Cells(10, 2)
Cells(1, 5).Value = Worksheets("Sheet2").Cells(10, 3)
Cells(1, 9).Value = Worksheets("Sheet2").Cells(10, 4)
Cells(1, 13).Value = Worksheets("Sheet2").Cells(10, 5)

End Sub
Sub Opnieuw_beginnen()
'Sheet2 Activeren
Sheets(2).Activate

'Data naar cel verplaatsen
Range("B3:E8").ClearContents


'Sheet1 Activeren
Sheets(1).Activate

'Activateren team1234reset
Run "team1234reset()"

End Sub

'Geluid afspelen
Sub geluid1()
Call sndPlaySound32("C:\Windows\Media\Windows Error.wav", 0)
End Sub
Sub geluid2()
Call sndPlaySound32("C:\Windows\Media\Windows Ding.wav", 0)
End Sub
Sub geluid3()
Call sndPlaySound32("C:\Windows\Media\Windows Battery Low.wav", 0)
End Sub
Sub geluid4()
Call sndPlaySound32("C:\Windows\Media\Windows Exclamation.wav", 0)
End Sub
'einde geluid afspelen
Sub einde_ronde()

Dim emptyRow As Long

'Sheet2 Activeren
Sheets(2).Activate

'Emptyrow definieren
emptyRow = WorksheetFunction.CountA(Range("B:B")) + 1

'Data naar cellen verplaatsen
Cells(emptyRow, 2).Value = Worksheets("Sheet1").Cells(1, 1)
Cells(emptyRow, 3).Value = Worksheets("Sheet1").Cells(1, 5)
Cells(emptyRow, 4).Value = Worksheets("Sheet1").Cells(1, 9)
Cells(emptyRow, 5).Value = Worksheets("Sheet1").Cells(1, 13)

'Sheet1 Activeren
Sheets(1).Activate

'Activeren team1234reset
Run "team1234reset()"


End Sub