od - vba Code: Vybrat vše
'------------------------------------------------------
' čtení textu
'------------------------------------------------------
Sub ProgressVoice(aSentence As Variant, Optional mode As Byte = 1)
Dim oVoice As Object ' deklarace objektu SpVoice
Dim oFSTRM As Object ' deklarace objektu SpFileStream
Dim iVoiceItem As Integer ' deklarace proměnné pro typ hlasu
Dim iVolume As Integer ' deklarace proměnné pro úroveň hlasitosti
Dim iRate As Integer ' deklarace proměnné pro úroveň tempa
Dim iAudioFormat As Integer ' deklarace pro audio formát (wav)
Dim iRadio As Integer ' deklarace proměnné pro položku volby TTS v MENU
Dim iColumn As Integer
Dim iRow As Integer
Dim iNumbering As Integer
Dim bNumbering As Boolean
Dim iFileDef As Byte
Dim iFormat As Byte
Dim sFileDef As String
Dim sText As String
Dim sPath As String
Dim sFile As String
Dim sTmp As String
Dim flag As Byte
Dim i As Integer
On Error GoTo ErrHandler ' návěstí pro zachytávání chyb
With ThisWorkbook.Sheets(SHVOICES) ' předvolby z listu VOICES
iVoiceItem = .Range(RNG_VOICE_ITEM) - 1 ' zvolená hlasová syntéza
iVolume = .Range(RNG_VOICE_VOLUME) ' zvolená hlasitost
iRate = .Range(RNG_VOICE_RATE) - 10 ' zvolené tempo hlasu
iAudioFormat = .Range(RNG_AUDIO_FORMAT) ' typ formátu wav
End With
With ThisWorkbook.Sheets(SHSAPI) ' předvolby z listu MENU
If .Shapes("rdb_1").ControlFormat.Value = 1 Then ' předvolby pro čtení / zápis textu
iRadio = 1
flag = SVSFLAGSASYNC ' čteme vše
ElseIf .Shapes("rdb_2").ControlFormat.Value = 1 Then
iRadio = 2
flag = SVSFISXML + SVSFLAGSASYNC ' aplikujeme tagy bbcode (TTS)
Else
iRadio = 3
flag = SVSFLAGSASYNC ' čteme text kromě definice tagů bbcode (TTS)
End If
If mode = 2 Or mode = 4 Then ' pouze pokud se jedná o zápis
sPath = fceGetOutFolder ' nastavíme cestu, kam se budou soubory zapisovat
If IsFolderExists(sPath) = False Then Error 50010 ' pokud je cesta neplatná, ukončíme
Select Case .Shapes("rdb_file1").ControlFormat.Value
Case 1
iFileDef = 1 ' název souboru: podle textu
Case Else
iFileDef = 2 ' název souboru: vlastní
If fceCheckValidCustomFileName = False Then GoTo Finish ' validace vlastního názvu souboru
sFileDef = Trim(.Range("file_custom_name")) ' sFileDef bude obsahovat šablonu pro název souboru
iFormat = fceCountOfSpecificChars(sFileDef, "#") ' pro formátování inkrementace názvu souboru
If .Shapes("chb_counter").ControlFormat.Value = 1 Then
iNumbering = Val(.Range("file_custom_numbering")) ' vlastní index číslování
Else
iNumbering = 0
End If
bNumbering = IIf(iNumbering <= 0, False, True)
End Select
If iAudioFormat = 1 Then ' pro výstupní formát wav (podle stahovacího seznamu)
iAudioFormat = 0
Else
iAudioFormat = iAudioFormat + 2
End If
End If
End With
' nastavíme objekt SAPI, včetně tempa a hlasitosti
Set oVoice = CreateObject("SAPI.SpVoice")
With oVoice
Set .voice = oVoice.GetVoices().item(iVoiceItem)
.volume = iVolume
.Rate = iRate
End With
Select Case mode ' podle typu výstupu...
Case 1
' čteme všechny označené buňky
With ThisWorkbook.Sheets(SHOUT)
For i = LBound(aSentence) To UBound(aSentence)
sText = Trim(.Cells(aSentence(i), COL_READ)) ' naplníme proměnnou sText aktuálním řádkem
Select Case iRadio
Case 2
sText = fceSVSFConvertToXML(sText, False) ' převod bbcode na TTS tagy
Case 3
sText = fceSVSFConvertToXML(sText, True) ' odstranění bbcode
End Select
If Len(sText) <> 0 Then ' text s nulovou délkou ignorujeme
With Application
.StatusBar = "Čte se řádek: " & aSentence(i) ' ve stavovém řádku zobrazíme číslo aktuálního řádku
.EnableCancelKey = xlErrorHandler ' možnost přerušení pomocí ESC
End With
With oVoice
.Speak sText, flag ' čtení
Do
Loop Until .WaitUntilDone(10) ' čekáme na konec (v této smyčce je možné čtení přerušit pomocí ESC)
'.WaitUntilDone (INFINITE)
End With
End If
Next
End With
Case 2
' zapíšeme všechny označené buňky
Set oFSTRM = CreateObject("SAPI.SpFileStream") ' nastavíme objekt SpFileStream
oFSTRM.Format.Type = iAudioFormat ' zvolený formát audia (wav)
With ThisWorkbook.Sheets(SHOUT)
For i = LBound(aSentence) To UBound(aSentence)
sText = Trim(.Cells(aSentence(i), COL_READ)) ' naplníme proměnnou sText aktuálním řádkem
If Len(sText) <> 0 Then ' text s nulovou délkou ignorujeme
' Select Case iFileDef
' Case 1
' sTmp = fceSVSFConvertToXML(sText, True) ' odstraníme tagy
' sTmp = fcePrepareFilename(sTmp, 255) ' připravíme název souboru z textu
' Case 2
' If bNumbering = True Then ' připravíme název souboru podle šablony
' sTmp = fceGetCustomFileName(sFileDef, _
' iNumbering, iFormat) ' vlatní číslování
' iNumbering = iNumbering + 1
' Else
' sTmp = fceGetCustomFileName(sFileDef, _
' aSentence(i), iFormat) ' číslování podle řádků
' End If
' End Select
sTmp = Trim(.Cells(aSentence(i), COL_FILE + 1))
Select Case iRadio
Case 2
sText = fceSVSFConvertToXML(sText, False) ' převod bbcode na TTS tagy
Case 3
sText = fceSVSFConvertToXML(sText, True) ' odstranění bbcode
End Select
sFile = sPath & sTmp & ".wav" ' definujeme název souboru včetně cesty a přípony
oFSTRM.Open sFile, SSFMCreateForWrite, True ' otevřeme stream pro zápis do souboru
Set oVoice.AudioOutputStream = oFSTRM ' objektu SpVoice definujeme výstup do streamu
With Application
.StatusBar = "Čte se řádek: " & aSentence(i) ' ve stavovém řádku zobrazíme číslo aktuálního řádku
.EnableCancelKey = xlErrorHandler ' možnost přerušení pomocí ESC
End With
With oVoice
.Speak sText, flag ' zápis čtení do souboru
Do
Loop Until .WaitUntilDone(10) ' čekáme na konec (v této smyčce je možné čtení přerušit pomocí ESC)
End With
oFSTRM.Close ' zavřeme stream
.Cells(aSentence(i), COL_FILE) = sTmp ' do příslušného sloupce zapíšeme název souboru bez cesty a bez přípony
End If
Next
End With
Case 3
' čteme všechny buňky ve sloupci
For i = 1 To UBound(aSentence) - 1
sText = Trim(aSentence(i, 1))
If Len(sText) <> 0 Then
Select Case iRadio
Case 2
sText = fceSVSFConvertToXML(sText, False) ' převod bbcode na TTS tagy
Case 3
sText = fceSVSFConvertToXML(sText, True) ' odstranění bbcode
End Select
With Application
.StatusBar = "Čte se řádek: " & i + ROW_FIRST - 1 ' do stavovém řádku uvedeme číslo řádku, se kterým se pracuje
.EnableCancelKey = xlErrorHandler ' možnost přerušení pomocí ESC
End With
With oVoice
.Speak sText, flag ' čteme text
Do
Loop Until .WaitUntilDone(10) ' v této smyčce je možné čtení přerušit pomocí ESC
End With
End If
Next
Case 4
' zapíšeme všechny buňky ve sloupci
Set oFSTRM = CreateObject("SAPI.SpFileStream") ' nastavíme objekt SpFileStream
oFSTRM.Format.Type = iAudioFormat ' zvolený formát audia (wav)
For i = 1 To UBound(aSentence) - 1
sText = Trim(aSentence(i, 1)) ' naplníme proměnnou sText z pole aSentence
If Len(sText) <> 0 Then ' text s nulovou délkou ignorujeme
' Select Case iFileDef
' Case 1
' sTmp = fceSVSFConvertToXML(sText, True) ' odstraníme tagy
' sTmp = fcePrepareFilename(sTmp, 255) ' připravíme název souboru z textu
' Case 2
' If bNumbering = True Then ' připravíme název souboru podle šablony
' sTmp = fceGetCustomFileName(sFileDef, _
' iNumbering, iFormat) ' vlatní číslování
' iNumbering = iNumbering + 1
' Else
' sTmp = fceGetCustomFileName(sFileDef, _
' i + ROW_FIRST - 1, iFormat) ' číslování podle řádků
' End If
' End Select
' čteme hodnoty ze sloupce D:
sTmp = Trim(ThisWorkbook.Sheets(SHOUT).Cells(i + ROW_FIRST - 1, COL_FILE + 1))
Select Case iRadio
Case 2
sText = fceSVSFConvertToXML(sText, False) ' převod bbcode na TTS tagy
Case 3
sText = fceSVSFConvertToXML(sText, True) ' odstranění bbcode
End Select
sFile = sPath & sTmp & ".wav" ' definujeme název souboru včetně cesty a přípony
oFSTRM.Open sFile, SSFMCreateForWrite, True ' otevřeme stream pro zápis do souboru
Set oVoice.AudioOutputStream = oFSTRM ' objektu SpVoice definujeme výstup do streamu
With Application
.StatusBar = "Čte se řádek: " & i + ROW_FIRST - 1 ' ve stavovém řádku zobrazíme číslo aktuálního řádku
.EnableCancelKey = xlErrorHandler ' možnost přerušení pomocí ESC
End With
With oVoice
.Speak sText, flag ' zapíšeme do souboru
Do
Loop Until .WaitUntilDone(10) ' v této smyčce je možné čtení přerušit pomocí ESC
End With
oFSTRM.Close ' zavřeme stream a zapíšeme do sloupce C
ThisWorkbook.Sheets(SHOUT).Cells(i - 1 + ROW_FIRST, COL_FILE) = sTmp
End If
Next
End Select
Finish:
With Application
.EnableCancelKey = xlInterrupt ' výchozí chování kláves ESC, Pause + Break
.StatusBar = False ' resetujeme status bar
End With
If IsObject(oFSTRM) Then Set oFSTRM = Nothing ' uklidíme po sobě
Set oVoice = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case 18 ' vynucené přerušení procedury
oVoice.Speak vbNullString, SVSFPURGEBEFORESPEAK
MsgBox "Přerušili jste proceduru.", vbExclamation, "Zastaveno"
Resume Finish
Case 432
sMsg = "Nelze zapsat do souboru:" & vbCrLf & vbCrLf & _
sFile & vbCrLf & vbCrLf & "Soubor se již používá nebo nemáte oprávnění k zápisu do této složky."
Case -2147200967
sMsg = "Pravděpodobně jste zadali chybný index hlasu (" & iVoice & ")" & vbCrLf & vbCrLf & _
"Chyba č.:" & Err.Number & vbCrLf & vbCrLf & "Popis chyby: " & Err.Description
Case 50010
sMsg = "Definovaná cesta pro zápis souborů není platná:" & vbCrLf & vbCrLf & sPath & _
vbCrLf & vbCrLf & "V " & SHSAPI & " definujte platnou cestu."
Case Else
sMsg = "Vyskytla se chyba č.:" & Err.Number & vbCrLf & vbCrLf & "Popis chyby: " & Err.Description
End Select
MsgBox sMsg, vbCritical, "Chyba"
Resume Finish
End Sub ' ==>> ProgressVoice
Název pro jeden soubor bude řešit tento řádek:
sTmp = Trim(.Cells(aSentence(i), COL_FILE + 1))
a pro více souborů tento řádek:
sTmp = Trim(ThisWorkbook.Sheets(SHOUT).Cells(i + ROW_FIRST - 1, COL_FILE + 1))
