Discussion :

[patricktoulon]

Bonjour a tous
il y a quelque temps hackoofr avait fait un petit hta utilisant le Google speech(voix Google )
aujourd'hui dans une autre discutions il en a sorti un autre en vbs plus performant
je n'en suis pas l'auteur mais je vous le livre car il a le merite de parfaitement fonctionner avec une intelligibilité plus que raisonnable
e
donc en vba ca donne ca :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
 
Option Explicit
 
Function dictée(texte)
Dim sTxt, URLFR
'sTxt =""
URLFR = "http://translate.google.com/translate_tts?ie=UTF-8&tl=fr&q=" & texte
If OnLine("smtp.gmail.com") = True Then
   Call Kill("wmplayer.exe")
   Call WmPlaySound(URLFR)
   Pause (10)
   Call Kill("wmplayer.exe")
End If
End Function
'**********************************************************************************************
Function OnLine(strHost)
Dim objPing, z, objRetStatus, PingStatus
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & strHost & "'")
    z = 0
    Do
        z = z + 1
        For Each objRetStatus In objPing
            If IsNull(objRetStatus.StatusCode) Or objRetStatus.StatusCode <> 0 Then
                PingStatus = False
            Else
                PingStatus = True
            End If
    Next
        Call Pause(1)
        If z = 4 Then Exit Do
    Loop Until PingStatus = True
    If PingStatus = True Then
        OnLine = True
    Else
        OnLine = False
    End If
End Function
'*********************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(Str)
   DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
   Sub WmPlaySound(MySound)
      Dim WshShell
      Set WshShell = CreateObject("WScript.Shell")
      WshShell.Run "wmplayer " & DblQuote(MySound) & "", 0, False
      Set WshShell = Nothing
   End Sub
'**********************************************************************************************
Sub Kill(Process)
      Dim Ws, Command, Execution
      Set Ws = CreateObject("WScript.Shell")
      Command = "cmd /c Taskkill /F /IM ""&Process&"""
      Execution = Ws.Run(Command, 0, True)
   End Sub
'**********************************************************************************************
   Sub Pause(NSeconds)
     ' Wscript.Sleep (NSeconds * 1000)
   End Sub
'**********************************************************************************************

et pour s'en servir il n'y a qu'a faire ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub test()
dictée "bonjour tout le monde ,comment sa va aujourd'hui" & vbCrLf & "je trouve que nous avons un beau soleil radieux "
End Sub

maintenant si on doit comparer avec le speech de l'application

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
Sub applicationsSpeech()
  Application.Speech.Speak "bonjour tout le monde ,comment sa va aujourd'hui" & vbCrLf & "je trouve que nous avons un beau soleil radieux "
 ' LE RESULTAT PARLE DE LUI MEME SANS COMMENTAIRE 
End Sub

sachant qu'avec seven il faut payer pour avoir une voix en Français

vous constaterez que le résultat est comment dire heu.....

je le répète je ne suis pas l'auteur de se script je l'ai juste remanier pour vba

mais j'ai pensé qu'il avait néanmoins ca place dans les contributions vba

je remercie encore hackoofr pour ces trouvailles toujours aussi spectaculaires les une que les autres

BIEN SUR POUR QU'IL FONCTIONNE IL FAUT ETRE CONNECTE!!!!!!



Voila bonne dictée

[Godzestla]

Impressionnant.

[Philippe Tulliez]

Bonjour,
Pas mal, assez surprenant.

[Marc-L]

Sympa Patrick !

maintenant si on doit comparer avec le speech de l'application

En changeant dans le code ligne n°7 fr par en ! …

Le Speech de mon côté est refusé sur une version 2003 …

Là non seulement on dispose d'une voix française correcte et il est facile de changer de pays !

[Marc-L]

Allez, à moi de t'embêter Patrick !

Suite à un plantage d'une application, je me suis rendu compte que l'application WMPlayer était toujours résidente.

Effectivement car, pour que ta fonction Kill fonctionne (attention ce mot-clef existe déjà en VBA !),

il faudrait corriger la ligne n°54 ainsi : Command = "cmd /c Taskkill /F /IM """ & Process & """" …

Erreur repérable car normalement sans espace après l'opérateur de concaténation & VBA met la ligne en erreur (rouge) …

Après cette correction, l'application est bien déchargée mais il n'y a plus de voix !
Normal car la ligne n°59 de la pause a été mise en commentaire …
Mais en la réactivant, cette ligne déclenche une erreur d'exécution '424' : Objet requis …

Je te laisse corriger ta sympathique contribution !

[patricktoulon]

Bonjour a tous
allez VBA pour VBA on reprend ca
marc voila une version qui pourra peut être t'apporter satisfaction
j'ai virer killprocess tel qu'elle l'était j'ai utilisé la recherche de processus en vba et j'ai refait une macro complète et fonctionnelle

j'ai remis aussi la pause
j'ai ajouté un argument a la fonction principale "le language"
maintenant on le déclare l'ors de l'appel a la fonction comme ca plus besoins de toucher au code
voila du pure VBA
qu'Est ce qu'il est exigeant ce marc alors
Vous remarquerez aussi des virgule qui n'ont pas leur place dans le texte ,en fait la virgule met un léger temps de silence en plus ce qui permet de rendre plus intelligible la dictée et d'avoir une ponctuation phonique plus ou moins correcte

Allez test en Français

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub test_en_francais()
dictée "bonjour tout le monde ,comment sa va aujourd'hui" & vbCrLf & "je trouve que nous avons un beau soleil radieux ", "fr"
End Sub

test en englais

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub test_en_englais()
dictée "hello every body ,,are you find today" & vbCrLf & "  ,, we ave a beautiful sun today ,,,,,,are you OK", "en"
End Sub

et maintenant le module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
 
Function dictée(texte, langue)
Dim sTxt, URLFR
'sTxt =""
URLFR = "http://translate.google.com/translate_tts?ie=UTF-8&tl=" & langue & "&q=" & texte
If OnLine("smtp.gmail.com") = True Then
   Wmplayer_stop
   Call WmPlaySound(URLFR)
   Pause (10)
  Wmplayer_stop
End If
End Function
'**********************************************************************************************
Function OnLine(strHost)
Dim objPing, z, objRetStatus, PingStatus
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").execquery("select * from Win32_PingStatus where address = '" & strHost & "'")
    z = 0
    Do
        z = z + 1
        For Each objRetStatus In objPing
            If IsNull(objRetStatus.StatusCode) Or objRetStatus.StatusCode <> 0 Then
                PingStatus = False
            Else
                PingStatus = True
            End If
    Next
        Call Pause(1)
        If z = 4 Then Exit Do
    Loop Until PingStatus = True
    If PingStatus = True Then
        OnLine = True
    Else
        OnLine = False
    End If
End Function
'*********************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(Str)
   DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
   Sub WmPlaySound(MySound)
      Dim WshShell
      Set WshShell = CreateObject("WScript.Shell")
      WshShell.Run "wmplayer " & DblQuote(MySound) & "", 0, False
      Set WshShell = Nothing
   End Sub
'**********************************************************************************************
Sub Wmplayer_stop()
    Dim service As Object
    Dim sQuery As String
    Dim processus
    Set service = GetObject("winmgmts:root\cimv2")
    sQuery = "select * from win32_process where name='" & "wmplayer.exe" & "'"
    For Each processus In service.execquery(sQuery)
        processus.Terminate
    Next
    Set service = Nothing
End Sub
'**********************************************************************************************
   Sub Pause(NSeconds)
    Application.Wait (Now + TimeValue("0:00:0" & NSeconds))
   End Sub
'**********************************************************************************************

et tout ca sans les apis! ca c'est kool


Un dernier petit essai

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub test_en_francais()
dictée "Marc n'est jamais content " & vbCrLf & "il en veut toujours plus " & "j'espère que celle la va lui convenir ", "fr"
End Sub

[Marc-L]

Là je n'ai plus le temps mais apparemment :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub Reponse()
    dictée "Va tutto bene !", "it"
End Sub

Enfin si pour chipoter : « English » c'est bien avec un E mais « Anglais » c'est avec un A et non pas un E !

[patricktoulon]

[patricktoulon]

re
Non vraiment ils sont fous ces toulonnais

j'avais fait il y a quelque temps cette contribution sur la translation(langue1/langue2) dynamique d'une cellule
j'ai repris une partie de ce code pour vous offrir la possibilité de faire la dictée d'un texte traduit
en effet vous entrez un texte dans une langue vous précisez la langue qu'il a été ecrit ,la langue dans le quel vous voulez qu'il soit traduit et la langue dont vous voulez qu'il soit dicté
voici la fonction a ajouter dans le module telquel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
'**********************************************************************************************
Public Function traduction(texte, LGin, LGout) As String
 Dim IE As Object, cel
    Set IE = CreateObject("InternetExplorer.application")
    'on ouvre la page avec les donnnées
    IE.navigate "http://translate.google.com/#" & LGin & "/" & LGout & "/" & texte
    IE.Visible = True    'rend invisible IE
    Do: Loop Until IE.readystate = 4 'attente du chargement complet de la page
    Application.Wait (Now + TimeValue("0:00:2"))    'attente de l'inscription des données dans le control et le resultat
    traduction = IE.Document.all("result_box").innertext    'on récupere la traduction
    IE.Quit    'on ferme l'object IE(l'instantiation d'internet explorer)
End Function
'***********************************************************************************************

voici comment on peut obtenir simplement le text

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub test_texte_avec_traduction()
msgbox traduction("good morning every body on developpez.com", "en", "fr")
End Sub

et voici comment on obtient la dictée du texte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Sub dictée_texte_avec_traduction()
dictée traduction("good morning every body on developpez.com", "en", "fr"), "fr"
End Sub

pour la fonction traduction
argument 1 =le texte que vous voulez
argument 2=la langue dans la quelle vous l'avez ecrite
argument 3= la langue dans la quelle vous voulez la traduire
testez les exemples

Non vraiment ils sont...........
edit:

j'oubliais voici quelques exemple de constantes representant les langues possible elles n'y sont pas toutes je donne les plus courante
'constante pour le choix des langues(je ne les ai pas toute mise seulement les plus courantes
'francais="fr"
'anglais="en"
'chinois="zh-CN"
'allemand="de"
'espagnol="es"
'russe="ru"
'Africain="af"
'italien="it"

[Marc-L]

Un dérivé logique !


Hier en partant de la contribution du post initial, j'ai commencé par mettre aussi la langue en paramètre,
passé ta fonction en procédure - la fonction ne renvoyant rien ! - puis compressé à ma sauce le code,
notamment la fonction OnLine, disposant de connexions câble avec un ping inférieur à 10ms même en Wi-Fi.
Par contre pas sûr qu'en ADSL cela passe … J'utilise ma fonction de pause utilisable jusqu'au centième de seconde,
pratique pour les animations (combiné à DoEvents) mais ici le dixième de seconde est raisonnable …
J'ai conservé le TaskKill mais directement inclus dans la procédure Voice,
je l'ai renommée car dictée peut rappeler de mauvais souvenirs à certains !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Function OnLine(HOST$) As Boolean
         Dim objRet As Object
    For Each objRet In GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery( _
                        "SELECT * FROM Win32_PingStatus WHERE Address = '" & HOST & "'")
        If Not IsNull(objRet.StatusCode) Then OnLine = objRet.StatusCode = 0
    Next
End Function
 
Sub Pause(Optional P! = 0.01)
     D! = Timer:   F! = D + P
 
    While Timer < F
       If Timer < D Then F = F - 86400: D = 0
    Wend
End Sub
 
Sub Voice(VTXT$, Optional VPAUSE!, Optional VKILL As Boolean, Optional ByVal VLANG$ = "fr")
        Const URL$ = "translate.google.com", WMP$ = "wmplayer.exe", _
              CMD$ = WMP & " ""http://" & URL & "/translate_tts?ie=UTF-8&tl="
    If OnLine(URL) = False Then Exit Sub
 
    With CreateObject("WScript.Shell")
        .Run CMD & VLANG & "&q=" & VTXT & """", 0
        If VPAUSE Then Pause VPAUSE
        If VKILL Then .Run "taskkill.exe /IM " & WMP & " /T /F", 0
    End With
End Sub
 
 
Sub Test()
      LANG = [{"de","en","es","it","fr"}]
    For N% = 1 To 5:  Voice "Super", 1.7, N = 5, LANG(N): Next:  End
End Sub

J'utiliserais ta deuxième méthode du post #6 ainsi :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub KillWMP()
         Dim Process As Object
    For Each Process In GetObject("winmgmts:root\cimv2").ExecQuery _
                                 ("SELECT * FROM Win32_Process WHERE Name = 'wmplayer.exe'")
             Process.Terminate
    Next
End Sub

Oui je sais, les goûts et le couleurs ! …

[patricktoulon]

Bonjour marc

tu n'a pas bien compris ma dernière mise a jour
en fait on rentre un texte dans une langue et il peut être dicté dans une autre langue
ta version change seulement l'accent (un américain qui parle Français )
tandis que ma dernière version traduit d'abord le texte et le dicte dans la langue de traduction
ca peut être pratique pour tes tutos en anglais pour ceux qui on du mal avec cette langue

[Marc-L]

J'ai très bien compris ta dernière mise à jour !

Comme le l'ai pourtant indiqué au début de mon chapitre - « Hier en partant de la contribution du post initial » -
mon code se réfère donc à ta contribution du post #1 ! Et j'ai même sauté deux lignes pour séparer le sujet …

[patricktoulon]

Bonjour a tous

je reviens un peu sur notre module dictée
j'en ai eu besoins et surprise ca ne fonctionne plus
l'url n'est plus bonne
la gestion du ping sur le serveur n'en parlons pas
la gestion du player qui etait deja une cata sa s'arrange pas
alors j'ai decider de revoir la copie

je n'utilise plus le player.exe j'utilise l'object wmplayer.ocx mais dans un vbs externe

1 creation du fichier vbs externe
2 grace a l'utilisation du ocx je n'ai pas besoins de gerer le ping su serveur smtp de gmail pour la gestion du player contrairement a l'ancienne version

3 la verification du playstate dans une boucle me permet de savoir quand c'est fini dans le code du vbs

4 parti de la je sais a quel moment je peut detruire le fichier vbs
comme je n'utilise plus le player.exe plus besoins de killer le process

l'avantage certain de cette methode c'est que le code vba n'est pas bloqué puisque tout ce passe en externe

cela peut servir eventuellement pour un message d'erreur ou d'alerte vocal par exemple
JE PRECISE TOUTE FOIS QUE SOUS CETTE FORME LE NOMBRE DE CARACTERES MAXIMUM EST 175 TOUT CONFONDUS
enfin bref je vous laisse le decouvrir
lancer le test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub test10()
    texte = texte & "Bonjour le forum " & vbCrLf
    texte = texte & " voici une nouvelle, plus legere, fonction dictée" & vbCrLf
    texte = texte & "utilisation, d'un fichier vbs externe, créé, dynamiquement" & vbCrLf
    texte = texte & "et s'auto détruit ,a la fin de la lecture" & vbCrLf
    Dictée2 texte, "fr"
End Sub

la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Function Dictée2(texte, langue)
    Dim code As String, chemin As String, SC
    texte = Replace(texte, vbCrLf, ", ")
    chemin = ThisWorkbook.Path & "\parle" & ".vbs"
    code = code & "Set wmp = CreateObject(""WMPlayer.OCX"")" & vbCrLf
    code = code & "wmp.settings.autoStart = True" & vbCrLf
    code = code & "wmp.settings.volume = 100" & vbCrLf
    code = code & "wmp.URL = ""https://translate.google.com/translate_tts?ie=UTF-8&q=" & texte & "&tl=" & langue & "&tk=514660&client=t&ttsspeed=1""" & vbCrLf
    code = code & "For i = 1 To 10000000" & vbCrLf
    code = code & "WScript.Sleep 1000" & vbCrLf
    code = code & "If wmp.playstate = 1 Then Exit For" & vbCrLf
    code = code & "Next" & vbCrLf
    code = code & "Set wmp = Nothing" & vbCrLf
    'code = code & "MsgBox ""terminé""" & vbCrLf
    code = code & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    code = code & "objFSO.DeleteFile (""" & chemin & """)"
    'On copie le code dans un fichier
    chemin = ThisWorkbook.Path & "\parle.vbs"
    Open chemin For Output As #1
    Print #1, code
    Close #1
    SC = """" & chemin & """ "
    With CreateObject("WScript.Shell")
        .Run SC
    End With
End Function

voila bonne utilisation

qu'en pensez vous

[patricktoulon]

re
la fonction traduction fonctionnait toujour alors voila je la remet en place avec ce principe

prochaine version possibilité d'un texte plus long que 175 caractere pour l'audio j'y travaille !!!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test()
MsgBox Dictée2(traduction("ello everybody how are you today", "en", "fr"), "fr")
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Public Function traduction(texte, LGin, LGout) As String
 Dim IE As Object, cel
    Set IE = CreateObject("InternetExplorer.application")
    'on ouvre la page avec les donnnées
    IE.navigate "http://translate.google.com/#" & LGin & "/" & LGout & "/" & texte
    IE.Visible = False    'rend invisible IE
    Do: Loop While IE.readystate <> 4 Or IE.busy 'attente du chargement complet de la page
    'Application.Wait (Now + TimeValue("0:00:2"))    'attente de l'inscription des données dans le control et le resultat
    traduction = IE.Document.all("result_box").innertext    'on récupere la traduction
    IE.Quit    'on ferme l'object IE(l'instantiation d'internet explorer)
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Function Dictée2(texte, langue)
    Dim code As String, chemin As String, SC
    texte = Replace(texte, vbCrLf, ", ")
    code = code & "Set wmp = CreateObject(""WMPlayer.OCX"")" & vbCrLf
    code = code & "wmp.settings.autoStart = True" & vbCrLf
    code = code & "wmp.settings.volume = 100" & vbCrLf
    code = code & "wmp.URL = ""https://translate.google.com/translate_tts?ie=UTF-8&q=" & texte & "&tl=" & langue & "&tk=100000&client=t&ttsspeed=1""" & vbCrLf
    code = code & "For i = 1 To 10000000" & vbCrLf
    code = code & "WScript.Sleep 1000" & vbCrLf
    code = code & "If wmp.playstate = 1 Then Exit For" & vbCrLf
    code = code & "Next" & vbCrLf
    code = code & "Set wmp = Nothing" & vbCrLf
    'code = code & "MsgBox ""terminé""" & vbCrLf
    code = code & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    code = code & "objFSO.DeleteFile (""" & chemin & """)"
    'On copie le code dans un fichier
    chemin = ThisWorkbook.Path & "\parle.vbs"
    Open chemin For Output As #1
    Print #1, code
    Close #1
    SC = """" & chemin & """ "
    With CreateObject("WScript.Shell")
        .Run SC
    End With
End Function

voila beaucoup plus saint et fluide que les versions précédentes

[Marc-L]

Bien vu Patrick l'utilisation de l'OCX, cela simplifie bien mes codes VBScript ! Plus besoin de mes procédures Pause & KillWMP …


Remarques :

• Ta ligne de code n°19 (ma préférée) de la fonction Dictée2 vient en double de la ligne n°5 (j'aime moins).

• En ajoutant seulement le paramètre client cela refonctionne …

• Pour la fluidité, telle quelle, c'est bien plus long qu'avec l'exécutable …

C'est "immédiat" en optimisant le Sleep comme dans ce script :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
With CreateObject("WMPlayer.ocx")
    With .settings:  .autoStart = True:  .volume = 100:  End With
    .url = "https://translate.google.com/translate_tts?ie=UTF-8&tl=fr&client=t&q=Bonjour !"
    While .playState > 1:  WScript.Sleep 1:  Wend
End With

[patricktoulon]

Bonjour Marc
oui
et non ca n'est pas plus long qu'avec l'executable j'ai controlé
a oui tu a raison
un oubli :le model tournait dans une boucle pour les playlist avant

bon daccords j'aurais pu utiliser une variable ca n'aurait pas supprimer une ligne

il semblerait qu'avec cet object on ai les meme propriétés que l'object windowmediaplayer dans VBA
pour les text plus long prevoir un split ou regex et faire une playlist
je suis en train de travailler dessus
en tout cas plus de soucis de ping sans reponse de process qui ne se termine pas ect......
si ca c'est pas plus fluide alors


au pire ecrire dans le vbs IE puis navigate puis element1 =texte1 puis puis option choix item langue puis click sur le bouton lecture le tout ie non visible

la lecture ce fait sans bloquer VBA

mais je vais quand meme m'interesser au playlist

En ajoutant seulement le paramètre client cela refonctionne …

ou ca ? il y est deja le paramettre client dan l'url

[patricktoulon]

re
bon effectivement meme l'ancienne url en ajoutant comme tu dis le parametre client ca fonctionne

j'ai meme essayé dans un ordre différent ca fonctionne aussi(client/tl/texte)
voila je l'ai remodelé comme ton model
alors sur une phrase courte c'est un peu plus rapide mais sur un texte pas de différence mais bon c'est plus propre
voila

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
sub test12()
dictée3 "bonjour","fr"
end sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Function Dictée3(texte, langue)
    Dim code As String, chemin As String, SC
    texte = Replace(texte, vbCrLf, ", ")
    code = code & "With CreateObject(""WMPlayer.ocx"")" & vbCrLf
    code = code & "With .settings:  .autoStart = True:  .volume = 100:  End With" & vbCrLf
    code = code & ".URL = ""https://translate.google.com/translate_tts?ie=UTF-8&tl=" & langue & "&client=t&q=" & texte & """" & vbCrLf
    code = code & "While .playState > 1:  WScript.Sleep 1:  Wend" & vbCrLf
    code = code & "End With" & vbCrLf
    code = code & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    code = code & "objFSO.DeleteFile (""" & chemin & """)"
    'On copie le code dans un fichier
    chemin = ThisWorkbook.Path & "\parle.vbs"
    Open chemin For Output As #1
    Print #1, code
    Close #1
    SC = """" & chemin & """ "
    With CreateObject("WScript.Shell")
        .Run SC
    End With
End Function

Marc l'utilisation du vbs externe est du aussi au fait que depuis WMP11 l'ocx ne fonctionne plus en vba

finalement cette petite tracasserie arrange bien tout le monde

[patricktoulon]

bonjour a tous
allez cette fois ci c'est la bonne !!!!
voila comme promis !!!! la version ultimate de la newversion en vbs externe
on peut lire
1° un mot,
2° une phrase,
3° un texte tout entier
plus de limite de caractères!!!!

le fichier vbs s'auto detruit toujours a la fin cette action est commandé par l'etat du player a la fin de la lecture

pour un mot ou une phrase l'état est stop "1"

pour un texte l'état est "10"("ready")

selon le mode des que l'on atteint ce state le fichier est detruit le process wscript est donc fini et ne figure plus dans les tache en execution

voila
ps: j'espere que marc n'aura rien a dire sur celui la hein !!!

sub de test :
teste un mot ou une phrase

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Sub test_ultimate_version_une_seule_phrase()
    texte = texte & "Bonjour le forum "
    Dictée4 texte, "fr"
End Sub

teste un texte

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test_ultimate_version_big_texte()
    Dim texte
    texte = texte & "Bonjour le forum " & vbCrLf
    texte = texte & " voici une nouvelle, plus legere, fonction dictée," & vbCrLf
    texte = texte & "utilisation de, l'objet WMplayer.OCX dans un fichier, vbs, externe, créé, dynamiquement" & vbCrLf
    texte = texte & "qui  s'autodétruit ,a la fin de la lecture" & vbCrLf
    texte = texte & "on peut maintenant, lire plus de 175 caractères " & vbCrLf
    texte = texte & "la fonction va découper le texte,  par les saut de ligne " & vbCrLf
    texte = texte & "et  créer, une url,  pour chaque ligne,  et la placer dans la playlist" & vbCrLf
    texte = texte & "dans l'objet WMP"
 
    Dictée4 texte, "fr"
End Sub

et maintenant la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Function Dictée4(texte, langue)
    Dim UrlPlay As String, chemin As String, phraselist1 As String, phraselist2 As String, liste, code As String, SC As String, fin As String
    fin = IIf(UBound(Split(texte, vbCrLf)) = 0, 1, 10)
    chemin = ThisWorkbook.Path & "\playlist.vbs"
    phraselist1 = "Set Xwmp = Wmp.newMedia("""
    phraselist2 = "Wmp.currentPlaylist.insertItem numPL, Xwmp"
    UrlPlay = "https://translate.google.com/translate_tts?ie=UTF-8&tl=langue&client=t&q=phrase"
    liste = Split(texte, vbCrLf)
    For i = 0 To UBound(liste)
        codeliste = codeliste & phraselist1 & Replace(Replace(UrlPlay, "langue", langue), "phrase", liste(i)) & Chr(34) & ")" & vbCrLf
        codeliste = codeliste & Replace(phraselist2, "numPL", i) & vbCrLf
    Next
    code = code & "Set wmp = CreateObject(""WMPlayer.ocx"")" & vbCrLf
    code = code & "wmp.settings.volume = 100" & vbCrLf
    code = code & codeliste & vbCrLf
    code = code & "Wmp.Controls.Play" & vbCrLf
    code = code & "While Wmp.playstate <> " & fin & ": wscript.sleep 1: Wend" & vbCrLf
    code = code & "Set Wmp = Nothing" & vbCrLf
    code = code & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    code = code & "objFSO.DeleteFile (""C:\Users\polux\Desktop\playlist.vbs"")" & vbCrLf
    'On copie le code dans un fichier
    Open chemin For Output As #1
    Print #1, code
    Close #1
    SC = """" & chemin & """ "
    With CreateObject("WScript.Shell")
        .Run SC
    End With
End Function

testez c'est vraiment bloffant
il ont fait beaucoup de progrès chez google en terme de voix

[Marc-L]

Oui bravo, c'est vraiment bluffant !

T'as juste laissé dans ta procédure Dictée4 le chemin en dur dans la ligne n°20 au lieu d'utiliser la variable !

Correction : code = code & "objFSO.DeleteFile (""" & chemin & """)" & vbCrLf …

[patricktoulon]

oui effectivement
pour le rendre completement generique le chemin par la variable

ensuite j'ai decouvert pourquoi le dictée avec traduction ne fonctionnait pas
enfait si on utilise la fonction traduction comme ci:
le texte renvoyé a les sut de ligne suprimés

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Public Function traduction1(texte, LGin, LGout) As String
 Dim IE As Object, cel
    Set IE = CreateObject("InternetExplorer.application")
    'on ouvre la page avec les donnnées
    IE.navigate "http://translate.google.com/#" & LGin & "/" & LGout & "/" & texte
    IE.Visible = False    'rend invisible IE
    Do: Loop While IE.readystate <> 4 Or IE.busy 'attente du chargement complet de la page
    'Application.Wait (Now + TimeValue("0:00:2"))    'attente de l'inscription des données dans le control et le resultat
    traduction1 = IE.document.all("result_box").innertext    'on récupere la traduction
    IE.Quit    'on ferme l'object IE(l'instantiation d'internet explorer)
End Function

maintenant si on utilise l'exploitation de htmlelemnt d'entrée et de sortie comme ceci:
le texte renvoyé respecte les saut de ligne mais c'est un peu plus long

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Public Function traduction2(texte, LGin, LGout) As String
    Dim IE As Object, cel
    Set IE = CreateObject("InternetExplorer.application")
    IE.navigate "https://translate.google.com/#" & LGin & "/" & LGout & "/"
    IE.Visible = False    'rend invisible IE
    Do: Loop While IE.readystate <> 4 Or IE.busy
    IE.document.getelementbyid("source").innertext = texte
    Do: Loop While IE.document.getelementbyid("result_box").innertext = ""
    texte = IE.document.getelementbyid("result_box").innertext & vbCrLf
    traduction2 = texte
    IE.Quit    'on ferme l'object IE(l'instantiation d'internet explorer)
End Function

alors j'ai modifié la 1 ere comme ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Public Function traduction4(texte, LGin, LGout) As String
    Dim IE As Object, cel
    texte = Replace(texte, vbCrLf, "(*)")
    Set IE = CreateObject("InternetExplorer.application")
    'on ouvre la page avec les donnnées
    IE.Visible = True     'rend invisible IE
    IE.navigate "http://translate.google.com/#" & LGin & "/" & LGout & "/" & texte
     Do: Loop While IE.readystate <> 4 Or IE.busy
   Do: Loop While IE.document.getelementbyid("result_box").innertext = ""
    traduction4 = Replace(IE.document.all("result_box").innertext, "(*)", vbCrLf)  'on récupere la traduction
    IE.Quit    'on ferme l'object IE(l'instantiation d'internet explorer)
End Function

donc c'est au choix pour la traduction (les gouts et les couleurs)

donc pour résumer
si on a la fonction dictée4 et traduction4
le test se fera comme ca
exemple dictée du texte en francais

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub test_ultimate_version_big_texte()
    Dim texte
    texte = texte & "Bonjour le forum " & vbCrLf
    texte = texte & " voici une nouvelle, plus legere, fonction dictée," & vbCrLf
    texte = texte & "utilisation de, l'objet WMplayer.OCX dans un fichier, vbs, externe, créé, dynamiquement" & vbCrLf
    texte = texte & "qui  s'autodétruit ,a la fin de la lecture" & vbCrLf
    texte = texte & "on peut maintenant, lire plus de 175 caractères " & vbCrLf
    texte = texte & "la fonction va découper le texte,  par les saut de ligne " & vbCrLf
    texte = texte & "et  créer, une url,  pour chaque ligne,  et la placer dans la playlist" & vbCrLf
    texte = texte & "dans l'objet WMP"
    Dictée4 texte, "fr"
End Sub

maintenant exemple de dictée du texte en francais traduit en anglais (anglais avec un A)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub test_ultimate_version_big_texte_langue1_to_langue2()
    Dim texte
    texte = texte & "Bonjour le forum " & vbCrLf
    texte = texte & " voici une nouvelle, plus legere, fonction dictée," & vbCrLf
    texte = texte & "utilisation de, l'objet WMplayer.OCX dans un fichier, vbs, externe, créé, dynamiquement" & vbCrLf
    texte = texte & "qui  s'autodétruit ,a la fin de la lecture" & vbCrLf
    texte = texte & "on peut maintenant, lire plus de 175 caractères " & vbCrLf
    texte = texte & "la fonction va découper le texte,  par les saut de ligne " & vbCrLf
    texte = texte & "et  créer, une url,  pour chaque ligne,  et la placer dans la playlist" & vbCrLf
    texte = texte & "dans l'objet WMP"
    Dictée4 traduction4(texte, "fr", "en"), "en"
End Sub

ET ENFIN !!!
LA POSSIBILITE DE TELECHARGER UN TEXTE EN MP3 avec l'api donwloadurl
ATTENTION 170 CARACTERES MAXIMUM
test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim llRetVal As Long
Sub testregfile()
texte = texte & "Bonjour le forum " & vbCrLf
    texte = texte & " voici une nouvelle, et plus legere, fonction dictée," & vbCrLf
    texte = texte & "utilisation de, l'objet WMplayer.OCX dans un fichier vbs, externe créé  dynamiquement" & vbCrLf
    texte = texte & "au revoir"
 
     Url_to_Mp3 texte, "test en mp3"
End Sub
 
Function Url_to_Mp3(texte, sname)
sautligne = "%2C%20": espace = "%20": virgule = "%20"
texto = Replace(Replace(Replace(texte, ",", virgule), vbCrLf, sautligne), " ", espace)
texto = Replace(Replace(texto, "éé", "eer"), "ée", "er")
URL = "https://translate.google.com/translate_tts?ie=UTF-8&tl=fr&client=t&q=" & texto & Chr(34)
MsgBox URL
llRetVal = URLDownloadToFile(0, URL, ThisWorkbook.Path & "\" & sname & ".mp3", 0, 0)
End Function

voila
le resultat meme traduit est bloffant !!!