Option Explicit
Public Abbruch As Boolean
Sub Spielerlisten_Ansage()
Dim s As Object
Dim ws As Worksheet
Dim r As Long
Dim nameH As String, nameD As String
Dim countH As Long, countD As Long
Dim herrenVorhanden As Boolean, damenVorhanden As Boolean
Dim txt As String, t
Set ws = Sheets("Spielerliste")
' ===========================
' ===== TURNIERART CHECK ====
' ===========================
nameH = ws.Cells(2, 2).Text ' Herren B2
nameD = ws.Cells(2, 8).Text ' Damen H2
herrenVorhanden = (nameH <> "")
damenVorhanden = (nameD <> "")
If Not herrenVorhanden And Not damenVorhanden Then
txt = txt & vbLf & "Es sind keine Spieler gemeldet."
Exit Sub
End If
If Not herrenVorhanden And damenVorhanden Then
txt = txt & vbLf & "Es wird ein reines Damenturnier gespielt."
ElseIf Not damenVorhanden And herrenVorhanden Then
txt = txt & vbLf & "Es wird ein Herren oder Mixed Turnier gespielt."
End If
' ===========================
' ===== STARTMELDUNG ========
' ===========================
txt = txt & vbLf & "Achtung! Es werden alle gemeldeten Spieler vorgelesen."
'Sleep 500
' ===========================
' ===== HERREN VORLESEN =====
' ===========================
If herrenVorhanden Then
If damenVorhanden Then
' Nur sagen, wenn beide vorhanden
txt = txt & vbLf & "Ich beginne mit den Herren."
End If
r = 2
nameH = ws.Cells(r, 2).Text
Do While nameH <> ""
txt = txt & vbLf & nameH
countH = countH + 1
r = r + 1
nameH = ws.Cells(r, 2).Text
Loop
End If
' ===========================
' ===== DAMEN VORLESEN ======
' ===========================
If damenVorhanden Then
If herrenVorhanden Then
' Nur sagen, wenn beide vorhanden
txt = txt & vbLf & "Nun folgen die Damen."
End If
r = 2
nameD = ws.Cells(r, 8).Text
Do While nameD <> ""
txt = txt & vbLf & nameD
countD = countD + 1
r = r + 1
nameD = ws.Cells(r, 8).Text
Loop
End If
' ===========================
' ===== ABSCHLUSSANSAGE =====
' ===========================
If countH > 0 And countD > 0 Then
txt = txt & vbLf & "Es sind " & countH & " Herren und " & countD & " Damen gemeldet."
ElseIf countH > 0 Then
txt = txt & vbLf & "Es sind " & countH & " Herren gemeldet."
ElseIf countD > 0 Then
txt = txt & vbLf & "Es sind " & countD & " Damen gemeldet."
End If
'=====================
'=== Sprachausgabe ===
'=====================
If MsgBox(txt, vbYesNo, "Ansage sprechen") = vbYes Then
For Each t In Split(txt, vbLf)
DoEvents
If Abbruch Then Exit For
Application.Speech.Speak t
DoEvents
Next
End If
Abbruch = False
End SubPrivate Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Abbruch = True
End SubOption Explicit
Public Abbruch As Boolean
Sub Spielerlisten_Ansage()
Dim s As Object
Dim ws As Worksheet
Dim r As Long
Dim nameH As String, nameD As String
Dim countH As Long, countD As Long
Dim herrenVorhanden As Boolean, damenVorhanden As Boolean
Dim txt As String, t
Set ws = Sheets("Spielerliste")
Set s = CreateObject("SAPI.SpVoice")
' ===========================
' ===== TURNIERART CHECK ====
' ===========================
nameH = ws.Cells(2, 2).Text ' Herren B2
nameD = ws.Cells(2, 8).Text ' Damen H2
herrenVorhanden = (nameH <> "")
damenVorhanden = (nameD <> "")
If Not herrenVorhanden And Not damenVorhanden Then
txt = txt & vbLf & "Es sind keine Spieler gemeldet."
Exit Sub
End If
If Not herrenVorhanden And damenVorhanden Then
txt = txt & vbLf & "Es wird ein reines Damenturnier gespielt."
ElseIf Not damenVorhanden And herrenVorhanden Then
txt = txt & vbLf & "Es wird ein Herren oder Mixed Turnier gespielt."
End If
' ===========================
' ===== STARTMELDUNG ========
' ===========================
txt = txt & vbLf & "Achtung! Es werden alle gemeldeten Spieler vorgelesen."
'Sleep 500
' ===========================
' ===== HERREN VORLESEN =====
' ===========================
If herrenVorhanden Then
If damenVorhanden Then
' Nur sagen, wenn beide vorhanden
txt = txt & vbLf & "Ich beginne mit den Herren."
End If
r = 2
nameH = ws.Cells(r, 2).Text
Do While nameH <> ""
txt = txt & vbLf & nameH
countH = countH + 1
r = r + 1
nameH = ws.Cells(r, 2).Text
Loop
End If
' ===========================
' ===== DAMEN VORLESEN ======
' ===========================
If damenVorhanden Then
If herrenVorhanden Then
' Nur sagen, wenn beide vorhanden
txt = txt & vbLf & "Nun folgen die Damen."
End If
r = 2
nameD = ws.Cells(r, 8).Text
Do While nameD <> ""
txt = txt & vbLf & nameD
countD = countD + 1
r = r + 1
nameD = ws.Cells(r, 8).Text
Loop
End If
' ===========================
' ===== ABSCHLUSSANSAGE =====
' ===========================
If countH > 0 And countD > 0 Then
txt = txt & vbLf & "Es sind " & countH & " Herren und " & countD & " Damen gemeldet."
ElseIf countH > 0 Then
txt = txt & vbLf & "Es sind " & countH & " Herren gemeldet."
ElseIf countD > 0 Then
txt = txt & vbLf & "Es sind " & countD & " Damen gemeldet."
End If
'=====================
'=== Sprachausgabe ===
'=====================
If MsgBox(txt, vbYesNo, "Ansage sprechen") = vbYes Then
For Each t In Split(txt, vbLf)
DoEvents
If Abbruch Then Exit For
s.Speak t
DoEvents
Next
End If
Abbruch = False
End SubOption Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Sub Spielerlisten_Ansage()
Dim s As Object
Dim ws As Worksheet
Dim r As Long
Dim nameH As String, nameD As String
Dim countH As Long, countD As Long
Dim herrenVorhanden As Boolean, damenVorhanden As Boolean
Set ws = Sheets("Spielerliste")
Set s = CreateObject("SAPI.SpVoice")
s.Speak "", 2
Sleep 300
' ===========================
' ===== TURNIERART CHECK ====
' ===========================
nameH = ws.Cells(2, 2).Text ' Herren B2
nameD = ws.Cells(2, 8).Text ' Damen H2
herrenVorhanden = (nameH <> "")
damenVorhanden = (nameD <> "")
If Not herrenVorhanden And Not damenVorhanden Then
s.Speak "Es sind keine Spieler gemeldet.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
Exit Sub
End If
If Not herrenVorhanden And damenVorhanden Then
s.Speak "Es wird ein reines Damenturnier gespielt.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
Sleep 400
ElseIf Not damenVorhanden And herrenVorhanden Then
s.Speak "Es wird ein Herren oder Mixed Turnier gespielt.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
Sleep 400
End If
' ===========================
' ===== STARTMELDUNG ========
' ===========================
s.Speak "Achtung! Es werden alle gemeldeten Spieler vorgelesen.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
Sleep 200
' ===========================
' ===== HERREN VORLESEN =====
' ===========================
If herrenVorhanden Then
If damenVorhanden Then
' Nur sagen, wenn beide vorhanden
s.Speak "Ich beginne mit den Herren.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
End If
r = 2
nameH = ws.Cells(r, 2).Text
Do While nameH <> ""
Debug.Print nameH
s.Speak nameH, 1
Do While s.Status.RunningState = 2
DoEvents
Loop
countH = countH + 1
r = r + 1
nameH = ws.Cells(r, 2).Text
Loop
Sleep 400
End If
' ===========================
' ===== DAMEN VORLESEN ======
' ===========================
If damenVorhanden Then
If herrenVorhanden Then
' Nur sagen, wenn beide vorhanden
s.Speak "Nun folgen die Damen.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
End If
r = 2
nameD = ws.Cells(r, 8).Text
Do While nameD <> ""
s.Speak nameD, 1
Do While s.Status.RunningState = 2
DoEvents
Loop
countD = countD + 1
r = r + 1
nameD = ws.Cells(r, 8).Text
Loop
Sleep 400
End If
' ===========================
' ===== ABSCHLUSSANSAGE =====
' ===========================
If countH > 0 And countD > 0 Then
s.Speak "Es sind " & countH & " Herren und " & countD & " Damen gemeldet.,1"
Do While s.Status.RunningState = 2
DoEvents
Loop
ElseIf countH > 0 Then
s.Speak "Es sind " & countH & " Herren gemeldet.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
ElseIf countD > 0 Then
s.Speak "Es sind " & countD & " Damen gemeldet.", 1
Do While s.Status.RunningState = 2
DoEvents
Loop
End If
End Sub
Option Explicit
Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
(ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
Const SND_ASYNC As Long = &H1
Const SND_FILENAME As Long = &H20000
Const SND_NOSTOP As Long = &H10
Sub SprecheZweiTexte()
Dim wav1$, wav2$
wav1 = Environ$("TEMP") & "\tts1.wav" ' kann nach Bedarf erweitert werden
wav2 = Environ$("TEMP") & "\tts2.wav"
TextToWav "Ich spreche einen Text und dieser kann jederzeit abgebrochen werden ohne dass es zu irgenwelchen seltsamen Sachen kommen dürfte", wav1
TextToWav "ein weiterer gesprochender Text", wav2
' kann man sowohl mit Schleife als einzeln weiter bauen
PlayWavAndWait wav1
PlayWavAndWait wav2
End Sub
Sub StopSound() ' Das stoppt das jeweilige laufende Wave da asynchron direkt
PlaySound vbNullString, 0, 0
End Sub
Sub TextToWav(text As String, wavPath As String)
Dim spk As Object, fil As Object
Set spk = CreateObject("SAPI.SpVoice")
Set fil = CreateObject("SAPI.SpFileStream")
fil.Open wavPath, 3 ' SSFMCreateForWrite
Set spk.AudioOutputStream = fil
spk.Speak text
fil.Close
End Sub
Sub PlayWavAndWait(wavPath As String)
Dim i#: i = Timer
PlayWavAsync wavPath
Do While Timer < i + 0.1
DoEvents
Loop
Do While SoundIsPlaying()
DoEvents
Loop
End Sub
Sub PlayWavAsync(wavPath As String)
PlaySound wavPath, 0, SND_ASYNC Or SND_FILENAME
End Sub
Function SoundIsPlaying() As Boolean ' PlaySound mit SND_NOSTOP gibt 0 zurück, wenn gerade ein Sound läuft
SoundIsPlaying = (PlaySound(vbNullString, 0, SND_NOSTOP) = 0)
End Function
Option Explicit
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As LongPtr) As Long
Dim WiedergabeListe As Collection, AktuellerIndex&, ResumePosition&, AktuellesWav$, PauseAktiv As Boolean, Abbruch As Boolean
Sub TextToWav(text As String, wavPath As String)
Dim spk As Object, fil As Object
mciSendString "close mywav", 0, 0, 0
Set spk = CreateObject("SAPI.SpVoice")
Set fil = CreateObject("SAPI.SpFileStream")
fil.Open wavPath, 3, False
Set spk.AudioOutputStream = fil
spk.Speak text
fil.Close
End Sub
Sub SpieleAktuellesWav()
If AktuellerIndex > WiedergabeListe.Count Then Exit Sub
AktuellesWav = WiedergabeListe(AktuellerIndex)
mciSendString "close mywav", 0, 0, 0
mciSendString "open """ & AktuellesWav & """ type waveaudio alias mywav", 0, 0, 0
mciSendString "play mywav", 0, 0, 0
PruefeWiedergabe
End Sub
Sub PauseWiedergabe()
PauseAktiv = True
mciSendString "pause mywav", 0, 0, 0
End Sub
Sub WeiterWiedergabe()
PauseAktiv = False
mciSendString "resume mywav", 0, 0, 0
PruefeWiedergabe
End Sub
Sub StopWiedergabe()
Abbruch = True
PauseAktiv = False
mciSendString "stop mywav", 0, 0, 0
mciSendString "close mywav", 0, 0, 0
End Sub
Function GetMciPosition() As Long
Dim ret As String * 32
mciSendString "status mywav position", ret, 32, 0
GetMciPosition = Val(ret)
End Function
Function GetMciLength() As Long
Dim ret As String * 32
mciSendString "status mywav length", ret, 32, 0
GetMciLength = Val(ret)
End Function
Sub PruefeWiedergabe()
Dim pos&, total&, t#
If PauseAktiv Or Abbruch Then Exit Sub
pos = GetMciPosition()
total = GetMciLength()
If pos >= total Then
AktuellerIndex = AktuellerIndex + 1
SpieleAktuellesWav
Exit Sub
End If
t = Timer
Do While Timer - t < 0.02 ' 20 ms warten
DoEvents
Loop
PruefeWiedergabe
End Sub
Sub StarteWiedergabeListe(ParamArray wavs() As Variant)
Dim i&
Set WiedergabeListe = New Collection
For i = LBound(wavs) To UBound(wavs)
WiedergabeListe.Add wavs(i)
Next i
AktuellerIndex = 1
PauseAktiv = False
Abbruch = False
SpieleAktuellesWav
End Sub
Sub TestTTSQueue()
Dim w1$, w2$, w3$
w1 = Environ$("TEMP") & "\tts1.wav"
w2 = Environ$("TEMP") & "\tts2.wav"
w3 = Environ$("TEMP") & "\tts3.wav"
TextToWav "Dies ist der erste Text.", w1
TextToWav "Dies ist der zweite Text.", w2
TextToWav "Dies ist der dritte Text.", w3
StarteWiedergabeListe w1, w2, w3
End Sub
Sub Spielerlisten_Ansage()
Dim s As Object
Dim ws As Worksheet
Dim r As Long
Dim nameH As String, nameD As String
Dim countH As Long, countD As Long
Dim herrenVorhanden As Boolean, damenVorhanden As Boolean
Dim sSpeak As String
Set ws = Sheets("Spielerliste")
Set s = CreateObject("SAPI.SpVoice")
s.Speak "", 2
Sprechen ". . . "
Sleep 300
' ===========================
' ===== TURNIERART CHECK ====
' ===========================
nameH = ws.Cells(2, 2).Text ' Herren B2
nameD = ws.Cells(2, 8).Text ' Damen H2
herrenVorhanden = (nameH <> "")
damenVorhanden = (nameD <> "")
If Not herrenVorhanden And Not damenVorhanden Then Sprechen "Es sind keine Spieler gemeldet.": Exit Sub
' s.Speak "Es sind keine Spieler gemeldet."
' Exit Sub
' End If
If Not herrenVorhanden And damenVorhanden Then
' s.Speak "Es wird ein reines Damenturnier gespielt."
sSpeak = "Es wird ein reines Damenturnier gespielt."
' Sleep 400
ElseIf Not damenVorhanden And herrenVorhanden Then
' s.Speak "Es wird ein Herren oder Mixed Turnier gespielt."
sSpeak = "Es wird ein Herren oder Mixed Turnier gespielt."
' Sleep 400
End If
Sprechen sSpeak
' ===========================
' ===== STARTMELDUNG ========
' ===========================
' s.Speak "Achtung! Es werden alle gemeldeten Spieler vorgelesen."
Sprechen "Achtung! Es werden alle gemeldeten Spieler vorgelesen."
Sleep 500
' ===========================
' ===== HERREN VORLESEN =====
' ===========================
If herrenVorhanden Then
If damenVorhanden Then Sprechen "Ich beginne mit den Herren."
' Nur sagen, wenn beide vorhanden
' s.Speak "Ich beginne mit den Herren."
' Sleep 300
' End If
r = 2
nameH = ws.Cells(r, 2).Text
Do While nameH <> ""
' s.Speak nameH
Sprechen nameH
countH = countH + 1
' Sleep 200
r = r + 1
nameH = ws.Cells(r, 2).Text
Loop
' Sleep 400
End If
' ===========================
' ===== DAMEN VORLESEN ======
' ===========================
If damenVorhanden Then
If herrenVorhanden Then
' Nur sagen, wenn beide vorhanden
' s.Speak "Nun folgen die Damen."
Sprechen "Nun folgen die Damen."
Sleep 300
End If
r = 2
nameD = ws.Cells(r, 8).Text
Do While nameD <> ""
' s.Speak nameD
Sprechen nameD
countD = countD + 1
' Sleep 200
r = r + 1
nameD = ws.Cells(r, 8).Text
Loop
Sleep 400
End If
' ===========================
' ===== ABSCHLUSSANSAGE =====
' ===========================
If countH > 0 And countD > 0 Then
' s.Speak "Es sind " & countH & " Herren und " & countD & " Damen gemeldet."
sSpeak = "Es sind " & countH & " Herren und " & countD & " Damen gemeldet."
ElseIf countH > 0 Then
' s.Speak "Es sind " & countH & " Herren gemeldet."
sSpeak = "Es sind " & countH & " Herren gemeldet."
ElseIf countD > 0 Then
' s.Speak "Es sind " & countD & " Damen gemeldet."
sSpeak = "Es sind " & countD & " Damen gemeldet."
End If
Sprechen sSpeak
End Sub
Private Function Sprechen(ByVal sText As String)
Static spr As Object
Const SVSFIsXML As Long = 8
If spr Is Nothing Then
Set spr = CreateObject("SAPI.SpVoice")
End If
sText = "" & _
"
" "
spr.Speak sText, 8
DoEvents
Sleep 200
End Function