IAVB3 v3.1.2.*
Table des procédures 1 - AssemblyInfo.vb 2 - clsIAVB.vb 2.1 - Private Function bAssertCMot 2.2 - Private Function bComposFonction 2.3 - Private Function bIndirection 2.4 - Private Function bRelationHorizontale 2.5 - Private Shared Function bQuestionResponseOui 2.6 - Private Sub AjoutBase 2.7 - Private Sub AjouterAssertion 2.8 - Private Sub AnalyseEntree 2.9 - Private Sub AnalyseMots 2.10 - Private Sub ControleExistenceMots 2.11 - Private Sub CopierPressePapier 2.12 - Private Sub EffacerBase 2.13 - Private Sub InitCmd 2.14 - Private Sub InitMotsIgnores 2.15 - Private Sub ListerBase 2.16 - Private Sub ReponseIAVB 2.17 - Private Sub SupprimerAssertion 2.18 - Private Sub Syllogisme 2.19 - Private Sub Syllogisme2 2.20 - Private Sub SyllogismeConclusion 2.21 - Private Sub TraiterCmd 2.22 - Public Sub CopiePressePapierEchec 2.23 - Public Sub CopiePressePapierOk 2.24 - Public Sub IAVBMain 2.25 - Public Sub Initialiser 3 - clsInitIAVB.vb 3.1 - Private Sub AjouterExemple 3.2 - Public Sub InitAssertionsExemples 3.3 - Public Sub New 4 - modVBUtil.vb 4.1 - Public Function iVBLen% 4.2 - Public Function iVBVal% 4.3 - Public Function sEnleverAccents$ 4.4 - Public Function sTrimRecursif$ 4.5 - Public Function sVBLeft$ 4.6 - Public Function sVBMid$ 4.7 - Public Function sVBMid$ 4.8 - Public Function sVBRight$ 4.9 - Public Function sVBTrim$ 4.10 - Public Function VBChr$ 5 - modDepart.vb 5.1 - Private Sub Depart 5.2 - Public Sub Main 6 - frmIAVB.vb 6.1 - Private Sub Activation 6.2 - Private Sub AjouterExemple 6.3 - Private Sub AssertionSuivante 6.4 - Private Sub chkAuto_Click 6.5 - Private Sub cmdGo_Click 6.6 - Private Sub cmdInstall_Click 6.7 - Private Sub cmdSuivant_Click 6.8 - Private Sub frmIAVB_Load 6.9 - Private Sub InitAssertionsExemples 6.10 - Private Sub Initialisations 6.11 - Private Sub InitVoix 6.12 - Private Sub ListAssert_DoubleClick 6.13 - Private Sub ListAssert_SelectedIndexChanged 6.14 - Private Sub listIA_DoubleClick 6.15 - Private Sub listIA_SelectedIndexChanged 6.16 - Private Sub listParole_SelectedIndexChanged 6.17 - Private Sub RecopierLigneListIA 6.18 - Private Sub textInput_KeyPress 6.19 - Private Sub TraiterAssertion 6.20 - Private Sub TraiterCmd 6.21 - Public Function bDire 6.22 - Public Sub PositionnerListIA 7 - modSynthVocaleMSAgent.vb 7.1 - Public Function bDireMSAgent 7.2 - Public Function bInitMSAgent 7.3 - Public Function bInstallationMSAgent 7.4 - Public Function bMasquerMSAgent 7.5 - Public Sub VerifierInstallAgent 8 - modUtil.vb 8.1 - Public Function bCleRegistreCRExiste 8.2 - Public Function bCopierPressePapier 8.3 - Public Function bFichierExiste 8.4 - Public Function bVerifierDllActiveX_InstExe 8.5 - Public Function Is64BitProcess 8.6 - Public Function sDossierParent$ 8.7 - Public Sub AfficherMsgErreur 8.8 - Public Sub Attendre 8.9 - Public Sub OuvrirAppliAssociee 8.10 - Public Sub TraiterMsgSysteme_DoEvents 9 - modUtilLT.vb 9.1 - Public Function bCreerObjet 9.2 - Public FunctionbVerifierInstallObjet AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("IAVB3")> <Assembly: AssemblyDescription( _ "Intelligence Artificielle Vraiment Basique - Par Patrice Dargenton." & _ " Logiciel original : publication de Philippe LARVET dans MICRO-SYSTEMES en Déc. 1984")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("IAVB3")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2017")> <Assembly: AssemblyTrademark("")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("3.1.2.*")> ' CA1017 : Marquer les assemblys avec ComVisible False <Assembly: Runtime.InteropServices.ComVisible(False)> <Assembly: CLSCompliant(True)> ' CA1014 : Marquer les assemblys avec CLSCompliantAttribute clsIAVB.vb ' Fichier clsIAVB.vb : Classe du moteur IAVB : Intelligence Artificielle en Visual Basic ' ------------------ ' Documentation : IAVB.html ' http://patrice.dargenton.free.fr/ia/iavb/IAVB.html ' http://patrice.dargenton.free.fr/ia/iavb/IAVB.vbproj.html ' https://github.com/PatriceDargenton/IAVB ' Version 3.12 du 18/06/2017 ' Version 3.10 du 06/12/2009 ' Version 3.01 du 02/09/2007 ' IAVB est la transcription en Visual Basic d'un logiciel paru dans la revue ' MICRO-SYSTEMES en Décembre 1984, pages 195-202 : ' "Mini-système expert pour Apple II" par Philippe LARVET : ' Gestion d'une base de connaissances. ' Par Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ Imports System.Text ' Pour StringBuilder Imports System.Collections.Generic Namespace IAVB Public Class clsIAVB #Region "Interface" ' Booléen pour forcer le fonctionnement dans la version originale (1984) ' ou bien modifiée (2001) Public m_bVersionModifiee As Boolean = True ' Normaliser les espaces et sauts de ligne en sortie Public m_bNormalisationSortieTrimEtVbLf As Boolean = True ' Convertir tout en minuscules (pour éviter d'avoir à taper des majuscules avec accent, ' et pour pouvoir prononcer "ça" via MS-Agent) Public m_bTraiterEnMinuscules As Boolean = True ' 29/04/2017 Enlever les accents (pour pouvoir comparer avec la version originale de 1984) Public m_bTraiterSansAccents As Boolean = True #End Region #Region "Constantes" Public ReadOnly vbLf$ = VBChr(10) ' Chr(10) ' CSharp : mettre "\n" Private Const sTitreMsg$ = "Moteur IAVB3" ' iNbMotsBCMax : Nbre de mots signifiants susceptibles ' d'être conservé en mémoire pour chaque assertion (au moins 3). ' seul les 2 premiers mots peuvent former une clé pour une relation H ou une indirection Private Const iNbMotsBCMax% = 4 ' Nbre de mots signifiants de l'entrée max. ' Peut être > iNbMotsBCMax notamment pour les compositions de fonctions Private Const iNbMotsEntreeMax% = 10 Private Const sEspace$ = " " Private sMotQU, sMotDonc, sMotEstComme, sMotEst, sMotSont As String Private sMotTou, sMotUn, sMotOr, sMotQuelque, sMotQuelques As String Private Const sGM$ = """" Private Const sPointInterrog$ = "?" Private Const sPointExclam$ = "!" Private Const sSlash$ = "/" Private Const sQuote$ = "'" Private Const sTiret$ = "-" Private Const sEgal$ = "=" Private Const sParenthOuv$ = "(" Private Const sParenthFerm$ = ")" Private Const sDeuxPoints$ = ":" Private Const sCmdSilenceOk$ = "Okay, je me tais." Private Const sCmdParlerOk$ = "Je vous écoute." Private Const sCmdCopieOk$ = "La discusion a été copiée dans le presse papier." Private Const sCmdCopiePb$ = "La discusion n'a pas pu être copiée dans le presse papier !" Private Const sCmdEffacerConfirm$ = "Voulez-vous effacer toute la base ?" Private Const sCmdEffacerOk$ = "Base entièrement effacée !" Private Const sCmdSupprAssertionOk1$ = "Assertion " ' & I & " supprimée" Private Const sCmdSupprAssertionOk2$ = " supprimée." Private Const sCmdSupprAssertionPb$ = "Numéro de l'assertion hors limites !" Private Const sReponseCompris$ = "Compris." '"Compris" Private Const sReponseConnaisPas$ = "Je ne connais pas " Private Const sReponseOui$ = "Oui." '"Oui" Private Const sReponseRienConclure$ = "Je ne peux rien conclure !" Private Const sReponseIgnore$ = "Je l'ignore." '"Je l'ignore" Private Const sReponseNon$ = "Non." '"Non" Private Const sReponseRechApprof$ = "Recherche approfondie..." Private Const sErrAssertionDejaConnue$ = "Assertion déjà connue !" 'Private Const sErrBasePleine$ = "Stop ! La base est pleine !" Private Const sErrPhraseTropCourte$ = "Votre phrase est trop courte !" Private Const sErrPhraseTropLongue$ = "Votre phrase est trop longue !" Private Const sErrPhraseIncomplete$ = "Votre phrase est incomplète !" Private Const sErrCmdInconnue$ = "Commande inconnue !" Private Const sErrBaseVide$ = "Base vide !" #End Region #Region "Classes" Private Class TAssertion Public iNbMots% Public asMot$() Public iPosFinMot1% Public iPosFinMot2% Public sEntree$ End Class Private Class TParamEntree Public bMotQuestion As Boolean Public bInterrogation As Boolean Public bFinTraitement As Boolean Public sEntree$ Public sEntreeCompilee$ ' Concaténation de tous les asMotsEntree$(i) Public iNbMotsEntree% ' Nbre de mots signifiants extraits de sEntree Public asMotsEntree$() ' Mots signifiants extraits de l'assertion Public iPosFinMot1%, iPosFinMot2% ' n° de l'assertion contenant le mot signifiant n°K de l'entrée, ' tableau des K mots de l'entrée ' D'abord la première assertion : ControleExistenceMots(), ' puis les assertions suivantes : bAssertCMot() pour les indirections. Public aiNumAssertCMot%() ' Conservation de l'indice minimum pour ' l'espace de recherche max. de l'assertion ' (contenant un des mots de l'assertion en cours) Public iNumAssertMinRech% End Class #End Region #Region "Déclarations" ' Liste des mots ignorés en général (non-signifiants) Dim m_lstMotsIgnores As New List(Of String) ' Dim = Private Dim m_lstBC As New List(Of TAssertion) ' Base de Connaissances (KB) Dim m_iNumAssertionEnCours% Dim m_bQuestionPreced_Donc As Boolean ' Préparer les réponses multiples pour les renvoyer en une seule chaine de caractères Private m_lsReponses As List(Of String) ' Pour pouvoir copier la discussion dans le presse papier Private m_lsReponsesTot As New List(Of String) ' Pour pouvoir synchroniser les réponses vocales avec les réponses écrites Private m_lsReponsesVocales As List(Of String) #End Region #Region "Interface" Public m_sRappelQuestion$ = "" Public m_sReponse$ = "" Public m_bCopierPressePapier As Boolean = False Public m_sDiscussion$ = "" Public sCmdEffBase, sCmdEff, sCmdLister As String Public sCmdCopier, sCmdSilence, sCmdParler As String Public m_bVoixActive As Boolean Public m_sReponseVocale$ = "" #End Region #Region "Fonctions publiques" Public Sub Initialiser(bVersionModifiee As Boolean, bNormalisationSortieTrimEtVbLf As Boolean, _ bTraiterEnMinuscules As Boolean, bTraiterSansAccents As Boolean) m_bVersionModifiee = bVersionModifiee m_bNormalisationSortieTrimEtVbLf = bNormalisationSortieTrimEtVbLf m_bTraiterEnMinuscules = bTraiterEnMinuscules m_bTraiterSansAccents = bTraiterSansAccents m_lstMotsIgnores = New List(Of String) m_lstBC = New List(Of TAssertion) InitCmd() InitMotsIgnores() End Sub Private Sub AjouterAssertion() Dim assert As New TAssertion ReDim assert.asMot(0 To iNbMotsBCMax) For i As Integer = 0 To iNbMotsBCMax assert.asMot(i) = "" Next m_lstBC.Add(assert) End Sub Public Sub IAVBMain(sEntree$) m_sReponseVocale = "" m_sDiscussion = "" m_bCopierPressePapier = False m_sRappelQuestion = "" : m_sReponse = "" m_lsReponses = New List(Of String) m_lsReponsesVocales = New List(Of String) Dim prm As New TParamEntree prm.sEntree = sEntree AnalyseEntree(prm) If prm.bFinTraitement Then Exit Sub Dim bRechecheApprofondie As Boolean If prm.bInterrogation And prm.asMotsEntree(1) = sMotDonc Then bRechecheApprofondie = False If m_bVersionModifiee And m_bQuestionPreced_Donc Then bRechecheApprofondie = True If m_iNumAssertionEnCours > 0 Then ReponseIAVB( _ m_lstBC(m_iNumAssertionEnCours).sEntree & sEspace & sDeuxPoints, bListe:=True) ReponseIAVB(sReponseRechApprof, bAffiche2Etoiles:=True, bListe:=True) End If Syllogisme(bRechecheApprofondie) m_bQuestionPreced_Donc = True Exit Sub End If m_bQuestionPreced_Donc = False If Not prm.bInterrogation Then If prm.iNbMotsEntree <= 1 Then ReponseIAVB(sErrPhraseTropCourte, bAffiche2Etoiles:=True) Exit Sub End If AjoutBase(prm) : Exit Sub End If ' Interrogation : controle existence des mots ControleExistenceMots(prm) If prm.bFinTraitement Then Exit Sub ' A vérifier : si prm.iNbMotsEntree > iNbMotsBCMax : relationH après réduction ? If prm.iNbMotsEntree <= iNbMotsBCMax Then If bRelationHorizontale(prm) Then Exit Sub End If ' Composition de fcts (relation verticale) If bComposFonction(prm) Then Exit Sub If bIndirection(prm) Then Exit Sub ' Echec Final If prm.bMotQuestion Then ReponseIAVB(sReponseIgnore, bAffiche2Etoiles:=True) Exit Sub End If ReponseIAVB(sReponseNon, bAffiche2Etoiles:=True) End Sub #End Region #Region "Moteur IAVB" Private Sub ReponseIAVB(ByRef sTexte$, _ Optional bAffiche2Etoiles As Boolean = False, _ Optional bRappelReponse As Boolean = False, _ Optional bSilence As Boolean = False, _ Optional sTexteParleSpecifique$ = "", _ Optional bListe As Boolean = False, _ Optional bFinListe As Boolean = False) If bFinListe Then ' Remplacer liste de String par une String & vbLf Dim sb As New StringBuilder For Each sReponse As String In m_lsReponses ' AppendLine ne convient pas If m_bNormalisationSortieTrimEtVbLf Then sb.Append(sReponse.Trim & vbLf) ' 09/04/2017 Normalisation des réponses Else sb.Append(sReponse & vbLf) End If Next m_sReponse = sb.ToString sb = New StringBuilder For Each sReponse As String In m_lsReponsesVocales sb.Append(sReponse & vbLf) Next m_sReponseVocale = sb.ToString Exit Sub End If Dim sTexteEcrit$ = sTexte If bAffiche2Etoiles Then sTexteEcrit = "** " & sTexte ' Affichage du texte avant de parler If bRappelReponse Then m_sRappelQuestion = sTexteEcrit Dim sTexteParle$ If m_bVoixActive And Not bSilence Then sTexteParle = sTexte If sTexteParleSpecifique.Length > 0 Then sTexteParle = sTexteParleSpecifique ' Il peut y avoir une liste de réponses vocales ' pb : on ne connait pas la fin de la liste ! ' Soluce : utiliser la même fin de liste qu'a l'affichage, ' et fait paire de réponses parlée/écrite : synchro + facile m_lsReponsesVocales.Add(sTexteParle) m_lsReponsesVocales.Add(sTexteEcrit) ' Pour la synchro. ' Préparer tjrs la réponse finale Dim sb As New StringBuilder For Each sReponse As String In m_lsReponsesVocales sb.Append(sReponse & vbLf) Next m_sReponseVocale = sb.ToString End If ' 09/04/2017 Normalisation des réponses If m_bNormalisationSortieTrimEtVbLf Then sTexteEcrit &= vbLf If Not bRappelReponse Then ' bSilence : commentaire, cmd, ou ligne vide : là aussi on se contente ' de répéter l'entrée : comme rappel question If bSilence Then m_sRappelQuestion = sTexteEcrit ElseIf bListe Then m_lsReponses.Add(sTexteEcrit) Else m_sReponse = sTexteEcrit End If End If m_lsReponsesTot.Add(sTexteEcrit) End Sub Private Sub AnalyseEntree(prm As TParamEntree) prm.bInterrogation = False prm.bInterrogation = False prm.bFinTraitement = False prm.bMotQuestion = False prm.iNbMotsEntree = 0 prm.sEntreeCompilee = "" ' Extraction des mots ReDim prm.asMotsEntree(0 To iNbMotsEntreeMax) ReDim prm.aiNumAssertCMot(0 To iNbMotsEntreeMax) For K As Integer = 1 To iNbMotsBCMax prm.asMotsEntree(K) = "" : prm.aiNumAssertCMot(K) = 0 Next K Dim iLenEntree% = iVBLen(prm.sEntree) ' Examen de l'entrée If iLenEntree = 0 Then ' Ligne vide ReponseIAVB(prm.sEntree, bSilence:=True) prm.bFinTraitement = True : Exit Sub End If ' Gestion des commentaires If sVBLeft(prm.sEntree, 1) = sQuote Then ReponseIAVB(prm.sEntree, bSilence:=True) prm.bFinTraitement = True : Exit Sub End If ' 29/04/2017 Enlever les accents, pour pouvoir comparer avec la version originale If m_bTraiterSansAccents Then prm.sEntree = sEnleverAccents(prm.sEntree) ' Convertir tout en minuscules pour pouvoir prononcer "ça" If m_bTraiterEnMinuscules Then prm.sEntree = prm.sEntree.ToLowerInvariant() If sVBLeft(prm.sEntree, 1) = sSlash Then ReponseIAVB(prm.sEntree, bSilence:=True) TraiterCmd(prm, iLenEntree) Exit Sub End If ' Afficher immédiatement le texte, sans attendre qu'il soit prononcé ReponseIAVB(prm.sEntree, bRappelReponse:=True) If sVBRight(prm.sEntree, 1) = sPointInterrog Then prm.sEntree = sVBLeft(prm.sEntree, iLenEntree - 1) iLenEntree = iVBLen(prm.sEntree) prm.bInterrogation = True End If AnalyseMots(prm, iLenEntree) End Sub Private Sub AnalyseMots(prm As TParamEntree, iLenEntree%) Dim iPos% = 1 ' Boucle sur les lettres Do Dim iMemPos% = iPos Dim sLettreEntree$ = "" Do iPos += 1 sLettreEntree = sVBMid(prm.sEntree, iPos, 1) Loop While iPos <= iLenEntree AndAlso sLettreEntree <> sEspace AndAlso _ sLettreEntree <> sQuote AndAlso sLettreEntree <> sTiret AndAlso _ sLettreEntree <> sParenthOuv AndAlso sLettreEntree <> sParenthFerm ' Chaque mot extrait de sEntree Dim sMotEntree$ = sVBMid(prm.sEntree, iMemPos, iPos - iMemPos) If iMemPos = 1 AndAlso sVBLeft(sMotEntree, 2) = sMotQU Then _ prm.bMotQuestion = True : GoTo RechercheMotSuivant Dim bMotIgnore As Boolean = False For Each sMotIgnore As String In m_lstMotsIgnores If sMotIgnore = sMotEntree Then bMotIgnore = True : Exit For Next If bMotIgnore Then GoTo RechercheMotSuivant ' Ajout d'un mot signifiant prm.iNbMotsEntree += 1 ' Modification : test aussi avec iNbMotsEntreeMax If (Not prm.bInterrogation AndAlso prm.iNbMotsEntree > iNbMotsBCMax) OrElse _ prm.iNbMotsEntree > iNbMotsEntreeMax Then ReponseIAVB(sErrPhraseTropLongue, bAffiche2Etoiles:=True) prm.bFinTraitement = True : Exit Sub End If prm.sEntreeCompilee = prm.sEntreeCompilee & sMotEntree prm.asMotsEntree(prm.iNbMotsEntree) = sMotEntree If prm.iNbMotsEntree = 1 Then prm.iPosFinMot1 = iPos If prm.iNbMotsEntree = 2 Then prm.iPosFinMot2 = iPos RechercheMotSuivant: If iPos > iLenEntree Then Exit Sub Do iPos += 1 Loop While sVBMid(prm.sEntree, iPos, 1) = sEspace AndAlso iPos <= iLenEntree Loop While iPos <= iLenEntree If prm.asMotsEntree(1) = "" Then ReponseIAVB(sErrPhraseIncomplete, bAffiche2Etoiles:=True) prm.bFinTraitement = True End If End Sub Private Sub TraiterCmd(prm As TParamEntree, iLenEntree%) If sVBLeft(prm.sEntree, sCmdLister.Length) = sCmdLister Then ListerBase(prm) : Exit Sub If sVBLeft(prm.sEntree, sCmdEffBase.Length) = sCmdEffBase Then EffacerBase(prm) : Exit Sub If sVBLeft(prm.sEntree, sCmdEff.Length) = sCmdEff Then SupprimerAssertion(prm, iLenEntree) : Exit Sub If sVBLeft(prm.sEntree, sCmdCopier.Length) = sCmdCopier Then CopierPressePapier(prm) : Exit Sub If sVBLeft(prm.sEntree, sCmdSilence.Length) = sCmdSilence Then ReponseIAVB(sCmdSilenceOk, bAffiche2Etoiles:=True) m_bVoixActive = False prm.bFinTraitement = True : Exit Sub End If If sVBLeft(prm.sEntree, sCmdParler.Length) = sCmdParler Then m_bVoixActive = True ReponseIAVB(sCmdParlerOk, bAffiche2Etoiles:=True) prm.bFinTraitement = True : Exit Sub End If ReponseIAVB(sErrCmdInconnue, bAffiche2Etoiles:=True) prm.bFinTraitement = True End Sub Private Sub ListerBase(prm As TParamEntree) Dim iNbAssertions% = m_lstBC.Count If iNbAssertions = 0 Then ReponseIAVB(sErrBaseVide, bAffiche2Etoiles:=True) ', bListe:=True) 'GoTo Fin prm.bFinTraitement = True Exit Sub End If For I As Integer = 0 To iNbAssertions - 1 ReponseIAVB((I + 1) & sEspace & m_lstBC(I).sEntree, bListe:=True) Next I Fin: ReponseIAVB("", bFinListe:=True) prm.bFinTraitement = True End Sub Private Sub CopierPressePapier(prm As TParamEntree) ' Copie du résultat d'exécution dans le presse papier Dim sbDisc As New StringBuilder() For Each sReponse As String In m_lsReponsesTot sbDisc.AppendLine(sReponse) Next m_sDiscussion = sbDisc.ToString ' La copie dans le presse-papier doit maintenant être faite depuis l'appelant ' on signale simplement ici que l'on a compris la commande m_bCopierPressePapier = True 'ReponseIAVB(sCmdCopieOk, bAffiche2Etoiles:=True) prm.bFinTraitement = True End Sub Public Sub CopiePressePapierOk() ReponseIAVB(sCmdCopieOk, bAffiche2Etoiles:=True) End Sub Public Sub CopiePressePapierEchec() ReponseIAVB(sCmdCopiePb, bAffiche2Etoiles:=True) End Sub Private Sub SupprimerAssertion(prm As TParamEntree, iLenEntree%) Dim i% = m_lstBC.Count If i = 0 Then ReponseIAVB(sErrBaseVide, bAffiche2Etoiles:=True) prm.bFinTraitement = True Exit Sub End If i -= 1 ' Par défaut effacer la dernière assertion If sVBMid(prm.sEntree, 3, 1) <> sEspace Then Dim sNumAssert$ = sVBRight(prm.sEntree, iLenEntree - 2) Dim iPosCom% = sNumAssert.IndexOf("'") If iPosCom > -1 Then sNumAssert = sNumAssert.Substring(0, iPosCom) ' ' Par défaut effacer la dernière assertion If sNumAssert.Trim = "" Then GoTo Suite i = iVBVal(sNumAssert) i -= 1 ' Indice 0 maintenant If i < 0 Or i >= m_lstBC.Count Then Dim sReponse$ = sCmdSupprAssertionPb & " " & i + 1 & " <> (" & 1 & ", " & m_lstBC.Count & ")" ReponseIAVB(sReponse, bAffiche2Etoiles:=True) prm.bFinTraitement = True Exit Sub End If End If Suite: m_lstBC.RemoveAt(i) ReponseIAVB(sCmdSupprAssertionOk1 & (i + 1) & sCmdSupprAssertionOk2, bAffiche2Etoiles:=True) prm.bFinTraitement = True End Sub Private Sub EffacerBase(prm As TParamEntree) Dim iNbAssertions% = m_lstBC.Count If iNbAssertions = 0 Then ReponseIAVB(sErrBaseVide, bAffiche2Etoiles:=True) prm.bFinTraitement = True : Exit Sub End If ' Pb : pas de confirmation vocale 'ReponseIAVB(sCmdEffacerConfirm, bAffiche2Etoiles:=True) If Not bQuestionResponseOui(sCmdEffacerConfirm) Then _ prm.bFinTraitement = True : Exit Sub m_lstBC = New List(Of TAssertion) ReponseIAVB(sCmdEffacerOk, bAffiche2Etoiles:=True) iNbAssertions = 0 prm.bFinTraitement = True End Sub Private Sub AjoutBase(prm As TParamEntree) ' Assertion : Controle existence de l'assertion dans la base Dim iNbAssertions% = m_lstBC.Count For I As Integer = 0 To iNbAssertions - 1 Dim sGdTerme$ = "" For J As Integer = 1 To iNbMotsBCMax sGdTerme &= m_lstBC(I).asMot(J) Next J If sGdTerme = prm.sEntreeCompilee Then If m_bVersionModifiee Then m_iNumAssertionEnCours = I ReponseIAVB(sErrAssertionDejaConnue, bAffiche2Etoiles:=True) Exit Sub End If Next I AjouterAssertion() Dim I1% = m_lstBC.Count - 1 For J As Integer = 1 To iNbMotsBCMax m_lstBC(I1).asMot(J) = prm.asMotsEntree(J) Next J Dim assert As TAssertion = m_lstBC(I1) assert.sEntree = prm.sEntree assert.iNbMots = prm.iNbMotsEntree assert.iPosFinMot1 = prm.iPosFinMot1 assert.iPosFinMot2 = prm.iPosFinMot2 ReponseIAVB(sReponseCompris, bAffiche2Etoiles:=True) m_iNumAssertionEnCours = m_lstBC.Count - 1 End Sub Private Sub ControleExistenceMots(prm As TParamEntree) ' Interrogation : contrôle de l'existence des mots Dim iNbAssertions% = m_lstBC.Count Dim iMemNumAssertionEnCours% = 0 m_iNumAssertionEnCours = iNbAssertions - 1 Dim iLenEntree% = iVBLen(prm.sEntree) prm.iNumAssertMinRech = iNbAssertions - 1 ' Utile pour la version modifiée For K As Integer = 1 To prm.iNbMotsEntree Dim bMotPresentAssertion As Boolean = False For I As Integer = 0 To iNbAssertions - 1 Dim bMotTrouve As Boolean = False Dim J% = 1 For J = 1 To m_lstBC(I).iNbMots If m_lstBC(I).asMot(J) = prm.asMotsEntree(K) Then bMotTrouve = True : Exit For Next J If Not bMotTrouve Then Continue For bMotPresentAssertion = True If prm.aiNumAssertCMot(K) = 0 Then prm.aiNumAssertCMot(K) = I If prm.iNbMotsEntree > 1 Then iMemNumAssertionEnCours = I : Exit For If J = 2 And iLenEntree > iVBLen(prm.asMotsEntree(K)) + 1 Then ReponseIAVB(sVBLeft(m_lstBC(I).sEntree, m_lstBC(I).iPosFinMot1), bListe:=True) ' Question spécifique, ex.: ' ET LAQUELLE EST FOFOLLE ? ' MINNA = Left(aBC(I).sEntree, aBC(I).iPosFinMot1) ' aBC(I).sEntree = MINNA EST FOFOLLE Continue For 'GoTo AssertionSuivante End If ReponseIAVB(m_lstBC(I).sEntree, bListe:=True) ' Entrée contenant le mot K : Question générique, ex.: ' RESPONSABLE ? ' M.BERTRAND EST RESPONSABLE DE L'ANNEXE ' M.JACQUES EST RESPONSABLE DE LA SAISIE Next I If Not bMotPresentAssertion Then Dim sReponse$ = sReponseConnaisPas & prm.asMotsEntree(K) ReponseIAVB(sReponse, bAffiche2Etoiles:=True) prm.bFinTraitement = True Exit Sub ' Pas de liste ici, quitter directement End If If prm.iNbMotsEntree = 1 Then prm.bFinTraitement = True GoTo Fin ' Liste possible ici End If ' Conserver l'indice minimum pour l'espace de recherche max. de l'assertion If m_bVersionModifiee Then If iMemNumAssertionEnCours < prm.iNumAssertMinRech Then _ prm.iNumAssertMinRech = iMemNumAssertionEnCours Else If iMemNumAssertionEnCours < m_iNumAssertionEnCours Then _ m_iNumAssertionEnCours = iMemNumAssertionEnCours End If Next K Fin: ReponseIAVB("", bFinListe:=True) End Sub Private Function bRelationHorizontale(prm As TParamEntree) As Boolean Dim aiMotsTrouves%(2) Dim bRelationHorizontale0 As Boolean = False Dim iDeb% = m_iNumAssertionEnCours If m_bVersionModifiee Then iDeb = prm.iNumAssertMinRech Dim iNbAssertions% = m_lstBC.Count For I As Integer = iDeb To iNbAssertions - 1 Dim iNbMotsTrouves% = 0 Dim iMemJ% = 1 For K As Integer = 1 To prm.iNbMotsEntree Dim bMotTrouve As Boolean = False Dim J% For J = iMemJ To m_lstBC(I).iNbMots If m_lstBC(I).asMot(J) = prm.asMotsEntree(K) Then bMotTrouve = True : Exit For Next J If bMotTrouve Then iNbMotsTrouves += 1 If iNbMotsTrouves <= 2 Then aiMotsTrouves(iNbMotsTrouves) = J End If iMemJ = J ' Force l'ordre de recherche à Sujet/Verbe/Complement seulement ' Cela permet de répondre Oui à la question : ' SABINE AIME-T-ELLE JACQUES ? ' et cela empêche de trouver une relation H à la question : ' JACQUES AIME-T-IL SABINE ? Next K If iNbMotsTrouves = 0 Then GoTo AssertionSuivante If iNbMotsTrouves = prm.iNbMotsEntree And iNbMotsTrouves = m_lstBC(I).iNbMots Then ReponseIAVB(sReponseOui, bAffiche2Etoiles:=True) Return True End If If iNbMotsTrouves <> prm.iNbMotsEntree Then GoTo AssertionSuivante bRelationHorizontale0 = True If aiMotsTrouves(1) = 1 And aiMotsTrouves(2) = 2 Then Dim iLenE% = iVBLen(m_lstBC(I).sEntree) ReponseIAVB(sVBRight(m_lstBC(I).sEntree, iLenE - m_lstBC(I).iPosFinMot2), bListe:=True) ' Ex.: ' QUI MARIE REGARDE-T-ELLE ? ' Réponse : HUGUES ' aBC(I).sEntree = MARIE REGARDE HUGUES GoTo AssertionSuivante End If If aiMotsTrouves(1) = 2 Then ReponseIAVB(sVBLeft(m_lstBC(I).sEntree, m_lstBC(I).iPosFinMot1), bListe:=True) ' Ex.: ' CHEF DE SERVICE ? ' M.RENE ' M.DUBOIS ' aBC(I).sEntree = M.RENE EST LE CHEF DU SERVICE COMPTABILITE ' aBC(I).sEntree = M.DUBOIS EST CHEF DU SERVICE PHOTO GoTo AssertionSuivante End If If aiMotsTrouves(1) = 3 Then ReponseIAVB(sVBLeft(m_lstBC(I).sEntree, m_lstBC(I).iPosFinMot2), bListe:=True) ' Ex.: ' SERVICE PHOTO ? ' M.DUBOIS EST CHEF GoTo AssertionSuivante End If ReponseIAVB(m_lstBC(I).sEntree, bListe:=True) ' Liste ' Pas d'exemple ! AssertionSuivante: Next I ReponseIAVB("", bFinListe:=True) Return bRelationHorizontale0 End Function Private Function bComposFonction(prm As TParamEntree) As Boolean ' Composition de fonction (relation verticale) Dim asMotReduit$(iNbMotsEntreeMax + 1) For K As Integer = 1 To prm.iNbMotsEntree asMotReduit(K) = prm.asMotsEntree(K) Next K Dim iNbAssertions% = m_lstBC.Count For K As Integer = prm.iNbMotsEntree To 2 Step -1 Dim sGdTerme$ = asMotReduit(K - 1) & asMotReduit(K) Dim bCompFct As Boolean = False ' Recherche des gd termes sur les mots n° 2 et 3 seulement de la BC : ' du type Y = F(X) : Y:1, F:2 et X:3, par ex.: BLANC = COULEUR(ARTABAN) Dim iDeb% = m_iNumAssertionEnCours If m_bVersionModifiee Then iDeb = prm.iNumAssertMinRech Dim I% For I = iDeb To iNbAssertions - 1 If m_lstBC(I).asMot(2) & m_lstBC(I).asMot(3) = sGdTerme Then bCompFct = True : Exit For Next I If Not bCompFct Then Return False asMotReduit(K - 1) = m_lstBC(I).asMot(1) Next K ' Fin de composition de fct : réponse trouvée ReponseIAVB(asMotReduit(1)) Return True ' Ex.: ' ARTABAN = CHEVAL(HENRI_IV) ' BLANC = COULEUR(ARTABAN) ' HENRI_IV = ROI(NAVARRE) ' COULEUR(CHEVAL(ROI(NAVARRE))) ? ' Réponse : BLANC ' sGdTerme = COULEURARTABAN End Function Private Function bIndirection(prm As TParamEntree) As Boolean Dim iMemNumAssertCMot2% = prm.aiNumAssertCMot(2) Dim bIndirection0 As Boolean = False Do prm.aiNumAssertCMot(2) = iMemNumAssertCMot2 Do Dim I1% = prm.aiNumAssertCMot(1) Dim I2% = prm.aiNumAssertCMot(2) For J1 As Integer = 1 To m_lstBC(I1).iNbMots Dim sGdTerme$ = m_lstBC(I1).asMot(J1) For J2 As Integer = 1 To m_lstBC(I2).iNbMots If sGdTerme <> m_lstBC(I2).asMot(J2) Then GoTo MotSuivant If I1 <> I2 And sGdTerme <> prm.asMotsEntree(1) And _ sGdTerme <> prm.asMotsEntree(2) And _ (prm.iNbMotsEntree <= 3 Or Not m_bVersionModifiee) Then ' Modification : il ne peut y avoir indirection que sur une ' question simple (au plus 3 termes signifiants) bIndirection0 = True ReponseIAVB(m_lstBC(I1).asMot(J1), bListe:=True) J1 = iNbMotsBCMax : J2 = iNbMotsBCMax ' Exit For 2x ' Ex.: QUELLE EST LA COULEUR DU STYLO DE FRANÇOIS ? ' Réponse : BLEU ' sGdTerme = BLEU, asMotsEntree(1) = COULEUR, asMotsEntree(2) = STYLO ' Ex.: QUELLE FILLE EST SAGE ? ' Réponse : ANNIE ' sGdTerme = ANNIE, asMotsEntree(1) = FILLE, asMotsEntree(2) = SAGE ' ARTABAN = CHEVAL(HENRI_IV) ' BLANC = COULEUR(ARTABAN) ' HENRI_IV = ROI(NAVARRE) ' Bonne indirection: ' QUEL ROI A UN CHEVAL ? : HENRI_IV ' Faille : mauvaise indirection ' CHEVAL DU ROI ? : HENRI_IV ' QUELLE EST LA COULEUR DU CHEVAL DU ROI ? : ARTABAN ' sGdTerme = ARTABAN ' prm.iNbMotsEntree = 3 : COULEUR, CHEVAL, ROI ' m_aBC(I1).asMot(J1) = ARTABAN ' prm.asMotsEntree(1) = COULEUR ' prm.asMotsEntree(2) = CHEVAL End If MotSuivant: Next J2 Next J1 Loop While bAssertCMot(prm, K:=2) Loop While bAssertCMot(prm, K:=1) ReponseIAVB("", bFinListe:=True) Return bIndirection0 End Function Private Function bAssertCMot(prm As TParamEntree, K%) As Boolean ' Module de recherche d'un prochain aiNumAssertCMot(K) Dim iDeb% = prm.aiNumAssertCMot(K) Dim iNbAssertions% = m_lstBC.Count For I As Integer = iDeb + 1 To iNbAssertions - 1 For J As Integer = 1 To m_lstBC(iDeb).iNbMots If m_lstBC(I).asMot(J) = prm.asMotsEntree(K) Then prm.aiNumAssertCMot(K) = I ' Ex.:ANIMAL MANGEUR ? ' Réponse : CHAT, TIGRE ' asMotsEntree(K) = MANGEUR dans les 2 cas Return True End If Next J Next I Return False End Function Private Sub Syllogisme(bRechecheApprofondie As Boolean) ' Recherche du moyen terme ' sPetitTerme$ : Petit terme extrait de l'assertion pour syllogisme ' sGdTerme$ : Concaténation de 2 ou 3 mots signifiants et extrait de l'assertion Dim bPasse2 As Boolean = False Dim iNbAssertions% = m_lstBC.Count Dim iNumAss2% = iNbAssertions - 1 If m_bVersionModifiee Then iNumAss2 = m_iNumAssertionEnCours ' Màj si assertion déjà connue Dim bAucunMotTrouve As Boolean = True Dim iAssertionPreced% = iNumAss2 - 1 ' Si bVersionModifiee seulement : If bRechecheApprofondie Then iAssertionPreced = 0 ' Recherche approfondie Dim iPas% = -1 Dim iDebut% = iNumAss2 - 1 Dim iFin% = iAssertionPreced Passe2: If bPasse2 Then iPas = 1 iDebut = iNumAss2 + 1 iFin = iNbAssertions - 1 End If For iNumAss1 As Integer = iDebut To iFin Step iPas Dim bMotTrouve As Boolean = False Dim iLenA1% = iVBLen(m_lstBC(iNumAss1).sEntree) Dim iLenA2% = iVBLen(m_lstBC(iNumAss2).sEntree) Dim iPosMT_PMaj% = 0 ' Place du moyen terme dans la prémisse majeure Dim iPosMT_PMin% = 0 ' Place du moyen terme dans la prémisse mineure Dim sMotPivot$ = "" For K As Integer = 1 To 3 For J As Integer = 1 To 3 If m_lstBC(iNumAss1).asMot(J) = "" Then GoTo MotSuivant If m_lstBC(iNumAss2).asMot(K) <> m_lstBC(iNumAss1).asMot(J) Then GoTo MotSuivant sMotPivot = m_lstBC(iNumAss2).asMot(K) bMotTrouve = True bAucunMotTrouve = False iPosMT_PMaj = J : iPosMT_PMin = K J = iNbMotsBCMax : K = iNbMotsBCMax ' Fin de boucle MotSuivant: Next J Next K If bRechecheApprofondie And Not bMotTrouve Then GoTo AssertionPrecedente If Not bRechecheApprofondie And Not bMotTrouve Then ReponseIAVB(sReponseRienConclure, bAffiche2Etoiles:=True) Exit Sub End If Dim bInversion As Boolean = False Dim bFctPetitTerme As Boolean = False Dim bFctGdTerme As Boolean = False Dim sPetitTerme$ = "" ' Résolution Select Case iPosMT_PMin Case 1 sPetitTerme = sVBRight(m_lstBC(iNumAss2).sEntree, _ iLenA2 - m_lstBC(iNumAss2).iPosFinMot1) ' Ex.: EST PHILOSOPHE If m_bVersionModifiee And sVBLeft(sPetitTerme, 4) = sMotEst & sEspace Then _ bInversion = True Case 2 sPetitTerme = sVBLeft(m_lstBC(iNumAss2).sEntree, m_lstBC(iNumAss2).iPosFinMot1) ' Ex.: "OR SOCRATE " Case 3 sPetitTerme = sVBLeft(m_lstBC(iNumAss2).sEntree, m_lstBC(iNumAss2).iPosFinMot2) If m_bVersionModifiee And sVBRight(sPetitTerme, 1) = sParenthOuv Then _ bFctPetitTerme = True End Select ' Ex.: OR TOUT HOMME SENSE If sVBLeft(sPetitTerme, 3) = sMotOr & sEspace Then sPetitTerme = _ sVBRight(sPetitTerme, iVBLen(sPetitTerme) - 3) Dim sGdTerme$ = "" Select Case iPosMT_PMaj Case 1 sGdTerme = sVBRight(m_lstBC(iNumAss1).sEntree, iLenA1 - m_lstBC(iNumAss1).iPosFinMot1) ' Ex.: "EST MORTEL" ' Ex.: "EST GREC" ' Ex.: "EST INCOMPRIS" If bFctPetitTerme And sVBLeft(sGdTerme, 4) = sMotEst & sEspace Then _ sGdTerme = sVBTrim(sVBRight(sGdTerme, iVBLen(sGdTerme) - 4)) & sEspace & sParenthFerm Case 2 Syllogisme2(iNumAss1, bFctPetitTerme, bInversion, sGdTerme) Case 3 sGdTerme = sVBLeft(m_lstBC(iNumAss1).sEntree, m_lstBC(iNumAss1).iPosFinMot2) If m_bVersionModifiee And sVBRight(sGdTerme, 1) = sParenthOuv Then _ bFctGdTerme = True End Select SyllogismeConclusion(iPosMT_PMin, iPosMT_PMaj, sPetitTerme, sGdTerme, _ bInversion, bFctGdTerme, sMotPivot) AssertionPrecedente: Next iNumAss1 If bRechecheApprofondie And Not bPasse2 Then bPasse2 = True : GoTo Passe2 ReponseIAVB("", bFinListe:=True) If bAucunMotTrouve Then ReponseIAVB(sReponseRienConclure, bAffiche2Etoiles:=True) End Sub Private Sub Syllogisme2(iNumAss1%, bFctPetitTerme As Boolean, bInversion As Boolean, _ ByRef sGdTerme$) sGdTerme = sVBLeft(m_lstBC(iNumAss1).sEntree, m_lstBC(iNumAss1).iPosFinMot1) If Not m_bVersionModifiee Then Exit Sub If sVBLeft(sGdTerme, 3) = sMotOr & sEspace Then If bFctPetitTerme Then _ sGdTerme = sVBTrim(sVBRight(sGdTerme, iVBLen(sGdTerme) - 3)) & sEspace & sParenthFerm : Exit Sub If bInversion Then sGdTerme = sVBTrim(sVBRight(sGdTerme, iVBLen(sGdTerme) - 3)) Else sGdTerme = sMotEstComme & sEspace & _ sVBTrim(sVBRight(sGdTerme, iVBLen(sGdTerme) - 3)) End If Exit Sub End If If bFctPetitTerme Then sGdTerme = sVBTrim(sGdTerme) & sEspace & sParenthFerm : Exit Sub If sVBLeft(sGdTerme, 3) <> sMotEst AndAlso sVBLeft(sGdTerme, 4) <> sMotSont AndAlso _ (sVBLeft(sGdTerme, 3) <> sMotTou OrElse Not bInversion) Then _ sGdTerme = sMotEstComme & sEspace & sVBTrim(sGdTerme) End Sub Private Sub SyllogismeConclusion(iPosMT_PMin%, iPosMT_PMaj%, sPetitTerme$, sGdTerme$, _ ByRef bInversion As Boolean, bFctGdTerme As Boolean, sMotPivot$) If iPosMT_PMin + iPosMT_PMaj = 2 Then If sVBLeft(sPetitTerme, 4) = sMotEst & sEspace Then sPetitTerme = sVBRight(sPetitTerme, iVBLen(sPetitTerme) - 4) If sVBLeft(sPetitTerme, 3) = sMotUn & sEspace Then _ sPetitTerme = sVBRight(sPetitTerme, iVBLen(sPetitTerme) - 3) sPetitTerme = sMotQuelque & sEspace & sVBTrim(sPetitTerme) & sEspace bInversion = False ElseIf sVBLeft(sPetitTerme, 5) = sMotSont & sEspace Then sPetitTerme = sVBRight(sPetitTerme, iVBLen(sPetitTerme) - 5) sPetitTerme = sMotQuelques & sEspace & sVBTrim(sPetitTerme) bInversion = False End If End If sPetitTerme = sVBTrim(sPetitTerme) sGdTerme = sVBTrim(sGdTerme) If m_bVersionModifiee Then ' 08/04/2017 If bInversion Then If sVBLeft(sGdTerme, 1) = sEgal Then sGdTerme = sVBMid(sGdTerme, 2) Else If sVBLeft(sPetitTerme, 1) = sEgal Then sPetitTerme = sVBMid(sPetitTerme, 2) End If End If Dim sConclusion$ = sMotDonc & sEspace & sPetitTerme & sEspace & sGdTerme If bInversion Then sConclusion = sMotDonc & sEspace & sGdTerme & sEspace & sPetitTerme If bFctGdTerme Then If bInversion Then sPetitTerme = sVBRight(sPetitTerme, iVBLen(sPetitTerme) - 4) sConclusion = sMotDonc & sEspace & sGdTerme & sEspace & sPetitTerme & sEspace & sParenthFerm End If Dim sConclusionParlee$ = sConclusion If m_bVersionModifiee Then sConclusion = sConclusion & " <" & sMotPivot & ">" ReponseIAVB(sConclusion, sTexteParleSpecifique:=sConclusionParlee, bListe:=True) ' Ex. de syllogisme : ' TOUT HOMME EST MORTEL ' OR SOCRATE EST UN HOMME ' DONC SOCRATE EST MORTEL ' Il y a plusieurs formes de syllogisme, la conclusion peut en varier : ' PLATON EST GREC ' OR PLATON EST PHILOSOPHE ' DONC QUELQUE PHILOSOPHE EST GREC ' Dans certains cas, un syllogisme peut être trouvé avec 2 mots au lieu d'un seul : ' TOUT LOGICIEN EST INCOMPRIS ' OR TOUT HOMME SENSE EST LOGICIEN ' DONC TOUT HOMME SENSE EST INCOMPRIS End Sub #End Region #Region "Initialisations" Private Sub InitCmd() sCmdEffBase = "/EFF" ' Effacer toute la base sCmdEff = "/D" ' Effacer la denière assertion, ou /Dn : l'assertion n° n sCmdLister = "/L" ' Lister les assertions de la base sCmdCopier = "/C" ' Copier la discussion dans le presse papier sCmdSilence = "/S" ' Mettre en sourdine sCmdParler = "/PARLE" ' Ré-activer la voix sMotQU = "QU" sMotDonc = "DONC" sMotEstComme = "EST COMME" sMotEst = "EST" sMotSont = "SONT" sMotTou = "TOU" '(TOUT, TOUS, TOUTES) sMotUn = "UN" sMotOr = "OR" sMotQuelque = "QUELQUE" sMotQuelques = "QUELQUES" If m_bTraiterEnMinuscules Then sCmdEffBase = sCmdEffBase.ToLowerInvariant() sCmdEff = sCmdEff.ToLowerInvariant() sCmdLister = sCmdLister.ToLowerInvariant() sCmdCopier = sCmdCopier.ToLowerInvariant() sCmdSilence = sCmdSilence.ToLowerInvariant() sCmdParler = sCmdParler.ToLowerInvariant() sMotQU = sMotQU.ToLowerInvariant() sMotDonc = sMotDonc.ToLowerInvariant() sMotEstComme = sMotEstComme.ToLowerInvariant() sMotEst = sMotEst.ToLowerInvariant() sMotSont = sMotSont.ToLowerInvariant() sMotTou = sMotTou.ToLowerInvariant() sMotUn = sMotUn.ToLowerInvariant() sMotOr = sMotOr.ToLowerInvariant() sMotQuelque = sMotQuelque.ToLowerInvariant() sMotQuelques = sMotQuelques.ToLowerInvariant() End If End Sub Private Sub InitMotsIgnores() ' Mots ignorés (car non-signifiants) ' "ETE" "ETAIT" "CA" m_lstMotsIgnores = New List(Of String) From { _ "EST", "LE", "LA", "DE", "UN", "UNE", "OR", "L", "DU", "D", "LES", "DES", "ET", "QU", "QUE", "QUI", "SONT", "IL", "ELLE", "A", "T", "ÉTÉ", "EN", "OU", "COMMENT", "AU", "N", "NE", "S", "SE", "ÉTAIT", "QUOI", "C", "CE", "QUEL", "QUELLE", "QUELS", "QUELLES", "PAR", "LEQUEL", "LAQUELLE", "ÇA", "SIGNIFIE", "TOUT", "TOUS", "TOUTE", "TOUTES", "(", ")", "=", "Y"} ' 29/04/2017 If m_bTraiterSansAccents Then For i As Integer = 0 To m_lstMotsIgnores.Count - 1 m_lstMotsIgnores(i) = sEnleverAccents(m_lstMotsIgnores(i)) Next End If If Not m_bTraiterEnMinuscules Then Exit Sub ' Convertir tout en minuscules For i As Integer = 0 To m_lstMotsIgnores.Count - 1 m_lstMotsIgnores(i) = m_lstMotsIgnores(i).ToLowerInvariant() Next End Sub Private Shared Function bQuestionResponseOui(sQuestion$) As Boolean Dim dlgResult As Windows.Forms.DialogResult = _ Windows.Forms.MessageBox.Show(sQuestion, sTitreMsg, _ Windows.Forms.MessageBoxButtons.YesNo, _ Windows.Forms.MessageBoxIcon.Question) If dlgResult = Windows.Forms.DialogResult.No Then Return False Return True End Function #End Region End Class End Namespace clsInitIAVB.vb Imports System.Collections.Generic Namespace IAVB Public Class clsInitIAVB Private m_lst As List(Of String) Public Sub New(lst As List(Of String)) m_lst = lst End Sub Private Sub AjouterExemple(sExemple$) m_lst.Add(sExemple) End Sub Public Sub InitAssertionsExemples() 'AjouterExemple(m_oIAVB.sCmdEff & " ' Effacer toute la base") 'AjouterExemple(m_oIAVB.sCmdEffDern & " ' Effacer la denière assertion") 'AjouterExemple(m_oIAVB.sCmdEffPrem & " ' Effacer l'assertion n°1") 'AjouterExemple(m_oIAVB.sCmdLister & " ' Lister les assertions de la base") 'AjouterExemple(m_oIAVB.sCmdCopier & " ' Copier la discussion dans le presse papier") 'AjouterExemple(m_oIAVB.sCmdTag & " ' Mettre en sourdine (autre poss.: masquer l'agent)") 'AjouterExemple(m_oIAVB.sCmdParler & " ' Ré-activer la voix") AjouterExemple("") AjouterExemple("TOUT STYLO EST BLEU") AjouterExemple("FRANÇOIS POSSÈDE UN STYLO") AjouterExemple("BLEU EST UNE COULEUR") AjouterExemple("ROUGE EST UNE COULEUR") AjouterExemple("TOUT STYLO EST EN PLASTIQUE") AjouterExemple("LE PLASTIQUE EST UNE MATIÈRE") AjouterExemple("FRANÇOIS POSSÈDE-T-IL UN STYLO ROUGE ?") AjouterExemple("QUELLE EST LA COULEUR DU STYLO DE FRANÇOIS ?") AjouterExemple("RAOUL A ACHETÉ UN STYLO ÉGALEMENT") AjouterExemple("DE QUELLE COULEUR EST LE STYLO DE RAOUL ?") AjouterExemple("TOUT STYLO EST EN QUELLE MATIÈRE ?") AjouterExemple("EN QUELLE MATIÈRE EST TOUT STYLO ?") AjouterExemple("' Limitation actuelle du logiciel : réponse fausse :") AjouterExemple("FRANÇOIS POSSÈDE-T-IL UN STYLO BLEU ?") AjouterExemple("FRANÇOIS POSSÈDE-T-IL UN STYLO ?") AjouterExemple("COULEUR STYLO FRANÇOIS ?") AjouterExemple("DE QUELLE COULEUR EST LE STYLO DE FRANÇOIS ?") AjouterExemple("") AjouterExemple("ANNIE EST UNE JOLIE FILLE") AjouterExemple("ANNIE EST SAGE") AjouterExemple("MINNA EST UNE FILLE ELLE AUSSI") AjouterExemple("MINNA EST FOFOLLE") AjouterExemple("QUELLE FILLE EST SAGE ?") AjouterExemple("ET LAQUELLE EST FOFOLLE ?") AjouterExemple("JOLIE EST LE CONTRAIRE DE LAIDE") AjouterExemple("EST-CE QU'ANNIE EST LAIDE ?") AjouterExemple("ÇA SIGNIFIE-T-IL QU'ANNIE EST UNE JOLIE FILLE ?") AjouterExemple("") AjouterExemple("JEAN REGARDE MARIE") AjouterExemple("MARIE REGARDE HUGUES") AjouterExemple("QUI MARIE REGARDE-T-ELLE ?") AjouterExemple("MARIE REGARDE-T-ELLE JEAN ?") AjouterExemple("HUGUES EST LE FRÈRE D'HENRI") AjouterExemple("HENRI EST LE FILS D'OCTAVE") AjouterExemple("OCTAVE EST L'ONCLE D'ANATOLE") AjouterExemple("QUI EST LE FILS DE L'ONCLE D'ANATOLE ?") AjouterExemple("ET QUI REGARDE LE FRÈRE DU FILS DE L'ONCLE D'ANATOLE ?") AjouterExemple("") AjouterExemple("L'ENTREPRISE A UN SIÈGE ET UNE ANNEXE") AjouterExemple("M.BERTRAND EST RESPONSABLE DE L'ANNEXE") AjouterExemple("L'ANNEXE A 15 SERVICES DIFFÉRENTS") AjouterExemple("M.JACQUES EST RESPONSABLE DE LA SAISIE") AjouterExemple("M.RENÉ EST LE CHEF DU SERVICE COMPTABILITÉ") AjouterExemple("M.MARTIN EST UN AMI DE M.JACQUES") AjouterExemple("M.DUBOIS EST CHEF DU SERVICE PHOTO") AjouterExemple("LA SAISIE EST UN SERVICE DÉCENTRALISÉ") AjouterExemple("RENAUD EST LE FILS DE M.BERTRAND") AjouterExemple("DAMIEN EST LE FILS DE M.RENÉ") AjouterExemple("CHEF DE SERVICE ?") AjouterExemple("CHEF DE SERVICE PHOTO ?") AjouterExemple("SERVICE PHOTO ?") AjouterExemple("RESPONSABLE ?") AjouterExemple("M.MARTIN EST L'AMI DE QUI ?") AjouterExemple("QUI EST LE FILS DU RESPONSABLE DES 15 SERVICES ?") AjouterExemple("QUI EST LE FILS D'UN CHEF DE SERVICE ?") AjouterExemple("QUI EST L'AMI DU RESPONSABLE D'UN SERVICE DÉCENTRALISÉ ?") AjouterExemple("") AjouterExemple("TOUT HOMME EST MORTEL") AjouterExemple("OR SOCRATE EST UN HOMME") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("TOUT HOMME EST BIPÈDE") AjouterExemple("OR PAUL EST UN HOMME") AjouterExemple("DONC ?") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("TOUT CE QUI EST RARE EST CHER") 'AjouterExemple("UN CHEVAL BON_MARCHE EST RARE") AjouterExemple("UN CHEVAL BON.MARCHÉ EST RARE") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("PLATON EST GREC") AjouterExemple("OR PLATON EST PHILOSOPHE") AjouterExemple("DONC ?") AjouterExemple("QUEL PHILOSOPHE EST GREC ?") AjouterExemple("Y A-T-IL UN PHILOSOPHE GREC ?") AjouterExemple("QUI EST GREC ET PHILOSOPHE ?") AjouterExemple("PHILOSOPHE GREC ?") AjouterExemple("PLATON EST-IL GREC ?") AjouterExemple("") AjouterExemple("LES SAVANTS SONT SOUVENT DISTRAITS") AjouterExemple("OR TOUS LES SAVANTS SONT BAVARDS") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("TOUS LES HOMMES SONT DES MORTELS") AjouterExemple("OR DES HOMMES SONT JUSTES") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("X1 = X2") AjouterExemple("X2 = X3") AjouterExemple("PAR QUOI X1 = X3 ?") AjouterExemple("") 'AjouterExemple("Y1 = F(X)") 'AjouterExemple("F(X) ?") 'AjouterExemple("X = G(T1)") 'AjouterExemple("V = K(W)") 'AjouterExemple("T1 = H(V)") 'AjouterExemple("F(G(H(K(W)) ?") AjouterExemple("Y1 = F DE X") AjouterExemple("F DE X ?") AjouterExemple("X = G DE T1") AjouterExemple("V = K DE W") AjouterExemple("T1 = H DE V") AjouterExemple("F DE G DE H DE K DE W ?") AjouterExemple("A QUOI EST = F DE G DE H DE K DE W ?") AjouterExemple("F G H K W ?") AjouterExemple("") AjouterExemple("CHAT = ANIMAL") AjouterExemple("CHAT = MANGEUR(SOURIS)") 'AjouterExemple("CHAT = MANGEUR DE SOURIS") AjouterExemple("TIGRE = ANIMAL") AjouterExemple("TIGRE = MANGEUR(HOMME)") ' Problème de syntaxe des syllogismes basée sur la détection des () ' si on change, certaines déductions ne marche plus : 'AjouterExemple("TIGRE = MANGEUR D'HOMME") AjouterExemple("ANIMAL MANGEUR ?") 'AjouterExemple("MANGEUR(HOMME) = ?") AjouterExemple("MANGEUR D'HOMME = ?") AjouterExemple("DONC ?") AjouterExemple("DONC ?") 'AjouterExemple("Y A-T-IL UN MANGEUR(SOURIS ET HOMME) ?") AjouterExemple("Y A-T-IL UN MANGEUR DE SOURIS ET D'HOMME ?") 'AjouterExemple("QUI EST MANGEUR(HOMME ET SOURIS) ?") AjouterExemple("QUI EST MANGEUR D'HOMME ET DE SOURIS ?") AjouterExemple("") 'AjouterExemple("ARTABAN = CHEVAL(HENRI_IV)") AjouterExemple("ARTABAN = CHEVAL DE HENRI.4") 'AjouterExemple("BLANC = COULEUR(ARTABAN)") AjouterExemple("BLANC = COULEUR D'ARTABAN") 'AjouterExemple("HENRI_IV = ROI(NAVARRE)") AjouterExemple("HENRI.4 = ROI DE NAVARRE") 'AjouterExemple("LOUIS_14 = ROI(FRANCE)") AjouterExemple("LOUIS.14 = ROI DE FRANCE") 'AjouterExemple("COULEUR(CHEVAL(ROI(NAVARRE)) ?") AjouterExemple("COULEUR DU CHEVAL DU ROI DE NAVARRE ?") AjouterExemple("QUELLE EST LA COULEUR DU CHEVAL DU ROI DE NAVARRE ?") AjouterExemple("QUELLE EST LA COULEUR DU CHEVAL BLANC DU ROI DE NAVARRE ?") AjouterExemple("' Faille : composition incomplète, mauvaise indirection :") AjouterExemple("QUELLE EST LA COULEUR DU CHEVAL DU ROI ?") AjouterExemple("' Bonne indirection :") AjouterExemple("QUEL ROI A UN CHEVAL ?") AjouterExemple("' Faille : mauvaise indirection :") AjouterExemple("CHEVAL DU ROI ?") AjouterExemple("CHEVAL DU ROI DE NAVARRE ?") AjouterExemple("CHEVAL DU ROI DE FRANCE ?") AjouterExemple("") AjouterExemple("LE CANARI EST UN OISEAU JAUNE") AjouterExemple("JAUNE EST UNE COULEUR") AjouterExemple("QUEL OISEAU EST JAUNE ?") AjouterExemple("QUEL EST L'OISEAU JAUNE ?") AjouterExemple("DE QUELLE COULEUR EST LE CANARI ?") AjouterExemple("QUELLE EST LA COULEUR DU CANARI ?") AjouterExemple("COULEUR CANARI ?") AjouterExemple("COULEUR ?") AjouterExemple("") AjouterExemple("MARSEILLE EST LA VILLE PHOCÉENNE") AjouterExemple("DEFERRE EST LE MAIRE DE MARSEILLE") AjouterExemple("PHOCÉENNE SIGNIFIE ORIGINAIRE DE PHOCÉE") AjouterExemple("LA PHOCÉE EST UNE PROVINCE GRECQUE") AjouterExemple("GASTON EST LE PRÉNOM DE DEFERRE") AjouterExemple("QUEL EST LE PRÉNOM DU MAIRE DE MARSEILLE ?") AjouterExemple("QUEL EST LE PRÉNOM DU MAIRE DE LA VILLE ORIGINAIRE D'UNE PROVINCE GRECQUE ?") AjouterExemple("' Test du système : composition de fonctions incomplète :") AjouterExemple("QUEL EST LE PRÉNOM DU MAIRE DE LA VILLE ORIGINAIRE D'UNE PROVINCE ?") AjouterExemple("' Autres réponses souhaitées : GASTON EST LE PRÉNOM DU MAIRE DE LA VILLE ORIGINAIRE D'UNE PROVINCE PHOCÉENNE") AjouterExemple("' ou bien : D'UNE PROVINCE PHOCÉENNE ?") AjouterExemple("' ou bien : ** heu... GASTON ?") AjouterExemple("") AjouterExemple("PAUL POSSÈDE UN PERROQUET BAVARD") AjouterExemple("MULTICOLORE SIGNIFIE DE PLUSIEURS COULEURS") AjouterExemple("UN PERROQUET EST UN ANIMAL MULTICOLORE") AjouterExemple("QUI POSSÈDE UN ANIMAL DE PLUSIEURS COULEURS ?") AjouterExemple("") AjouterExemple("MARIE EST UNE JOLIE FILLE") AjouterExemple("JOLIE EST LE CONTRAIRE DE LAIDE") AjouterExemple("MARIE EST-ELLE LAIDE ?") AjouterExemple("EST-CE QUE MARIE EST LAIDE ?") AjouterExemple("") AjouterExemple("SABINE AIME JACQUES") AjouterExemple("QUI AIME JACQUES ?") AjouterExemple("QUI AIME SABINE ?") AjouterExemple("QUI JACQUES AIME-T-IL ?") AjouterExemple("' Meilleure réponse : Je L'ignore :") AjouterExemple("JACQUES AIME-T-IL SABINE ?") AjouterExemple("SABINE AIME-T-ELLE JACQUES ?") AjouterExemple("") AjouterExemple("' Capacités de la version modifiée :") AjouterExemple("' Ordre des termes : DONC TOUT CHEVAL EST HERBIVORE :") AjouterExemple("TOUT CHEVAL EST UN ÉQUIDÉ") AjouterExemple("OR TOUT ÉQUIDÉ EST HERBIVORE") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("' Sens logique : DONC PAUL EST COMME TOUT HOMME :") AjouterExemple("TOUT HOMME EST BIPÈDE") AjouterExemple("OR PAUL EST BIPÈDE") AjouterExemple("DONC ?") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("' Sens logique : ARISTOTE EST COMME TOUT HOMME :") AjouterExemple("TOUT HOMME EST RATIONNEL") AjouterExemple("OR ARISTOTE EST RATIONNEL") AjouterExemple("DONC ?") AjouterExemple("ARISTOTE ÉTAIT GREC") AjouterExemple("ARISTOTE ÉTAIT PHILOSOPHE") AjouterExemple("PHILOSOPHE GREC ?") AjouterExemple("") AjouterExemple("' Syllogismes : ordre des assertions") AjouterExemple("OR SOCRATE EST UN HOMME") AjouterExemple("TOUT HOMME EST MORTEL") AjouterExemple("DONC ?") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("' Syllogismes : plusieurs à la fois") AjouterExemple("TOUT HOMME EST MORTEL") AjouterExemple("TOUT HOMME EST BIPÈDE") AjouterExemple("OR SOCRATE EST UN HOMME") AjouterExemple("DONC ?") AjouterExemple("OR PAUL EST UN HOMME") AjouterExemple("DONC ?") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("TOUT LOGICIEN EST INCOMPRIS") AjouterExemple("OR TOUT HOMME SENSÉ EST LOGICIEN") AjouterExemple("DONC ?") AjouterExemple("") AjouterExemple("' Syllogismes : syntaxe imparfaite (de la version modifiée)") AjouterExemple("LE LOUVRE EST BEAU") AjouterExemple("OR J'AIME TOUT CE QUI EST BEAU") AjouterExemple("DONC ?") AjouterExemple("") End Sub End Class End Namespace modVBUtil.vb Imports System.Text ' Pour StringBuilder Imports System.Text.Encoding ' Pour GetEncoding Module modVBUtil ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 Private Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern ' L'encodage UTF-8 est le meilleur compromis encombrement/capacité ' il permet l'encodage par exemple du grec, sans doubler la taille du texte '(mais le décodage est plus complexe en interne et les caractères ne s'affichent ' pas bien dans les certains logiciels utilitaires comme WinDiff, ' ni par exemple en csv pour Excel) ' http://fr.wikipedia.org/wiki/Unicode ' 65001 = Unicode UTF-8, 65000 = Unicode UTF-7 Private Const iEncodageUnicodeUTF8% = 65001 #Region "VBUtil" Public Function sVBLeft$(sTxt$, iLeft%) Dim iLong% = sTxt.Length If iLeft > iLong Then Return sTxt Dim sLeft$ = sTxt.Substring(0, iLeft) Return sLeft End Function Public Function sVBRight$(sTxt$, iRight%) Dim iLong% = sTxt.Length If iRight > iLong Then Return sTxt Dim sRight$ = sTxt.Substring(iLong - iRight, iRight) Return sRight End Function Public Function iVBLen%(sTxt$) Return sTxt.Length End Function Public Function sVBMid$(sTxt$, iDeb%) Dim sMid$ = sTxt.Substring(iDeb - 1) Return sMid End Function Public Function sVBMid$(sTxt$, iDeb%, iLong%) Dim sMid$ If iLong + iDeb - 1 > sTxt.Length Then sMid = "" Else sMid = sTxt.Substring(iDeb - 1, iLong) End If Return sMid End Function Public Function sVBTrim$(sTxt$) Dim sTrim2$ = sTrimRecursif(sTxt) Return sTrim2 End Function Public Function sTrimRecursif$(sTxt$) ' Fonction récursive ! Attention aux performances : mauvaise idée ! ' (héritage Microsoft.VisualBasic.dll) Dim str2$ Dim iLong% = sTxt.Length If (sTxt Is Nothing) OrElse iLong = 0 Then Return "" Select Case sTxt.Chars(0) Case " "c : Return sTrimRecursif(sTxt.Substring(1)) 'Case " "c, ChrW(12288) : Return sTrimRecursif(sTxt.Substring(1)) End Select Select Case sTxt.Chars(iLong - 1) Case " "c : Return sTrimRecursif(sTxt.Substring(0, iLong - 1)) 'Case " "c, ChrW(12288) : Return sTrimRecursif(sTxt.Substring(0, iLong - 1)) End Select str2 = sTxt Return str2 End Function Public Function iVBVal%(sTxt$, Optional iValDef% = 0) Dim iRes% If Integer.TryParse(sTxt, iRes) Then Return iRes Return iValDef End Function Public Function VBChr$(iCharCode%) Dim cChrConvert As Char = System.Convert.ToChar(iCharCode) Return cChrConvert End Function #End Region Public Function sEnleverAccents$(sChaine$, Optional bTexteUnicode As Boolean = False) 'Optional bMinuscule As Boolean = True ' Enlever les accents (voir aussi modUtilFichier.sConvNomDos) If sChaine.Length = 0 Then sEnleverAccents = "" : Exit Function Const sEncodageIso8859_15$ = "iso-8859-15" Const sEncodageIso8859_8$ = "iso-8859-8" 'Const sEncodageDest$ = "windows-1252" ' Frédéric François, cœur ' iso-8859-8 -> windows-1252 : Frederic Francois, cour ' Meilleure solution ' windows-1251 -> windows-1252 : Frederic Francois, c?ur ' Ancienne solution ' iso-8859-15 -> windows-1252 : Frédéric François, c½ur ' Utile pour détecter <> ' Codepage 1241 = "windows-1251" = cyrillic ' Tableau de caractères sur 8 bit 'Dim aOctets As Byte() = GetEncoding(1251).GetBytes(sChaine) ' Chaîne de caractères sur 7 bit 'sEnleverAccents = ASCII.GetString(aOctets) ' Ok mais reste cœur qui est converti en c?ur Dim iEncodageDest% = iCodePageWindowsLatin1252 If bTexteUnicode Then iEncodageDest = iEncodageUnicodeUTF8 Dim encodage1252 As Encoding = GetEncoding(iCodePageWindowsLatin1252) Dim encodage8859_8 As Encoding = GetEncoding(sEncodageIso8859_8) Dim encodageDest As Encoding = GetEncoding(iEncodageDest) Dim encodageIso8859_15 As Encoding = GetEncoding(sEncodageIso8859_15) Dim aOctets As Byte() = encodage8859_8.GetBytes(sChaine) ' "iso-8859-8" sEnleverAccents = encodageDest.GetString(aOctets) ' 1252 ou UTF8 'If bDebug Then Debug.WriteLine("' " & sEncodageSrc & " -> " & sEncodageDest & " : " & sEnleverAccents) ' Détection des caractères propres à iso-8859-15 : ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ ' http://fr.wikipedia.org/wiki/ISO_8859-15 If String.Compare(encodageIso8859_15.GetString( _ encodage1252.GetBytes(sChaine)), sChaine) = 0 Then GoTo Fin Dim i% = 0 Dim iLen% = sChaine.Length Dim sChaineIso$ = encodageIso8859_15.GetString(encodageDest.GetBytes(sChaine)) Dim ac1, ac2, ac3 As Char() ac1 = sChaine.ToCharArray ac2 = sChaineIso.ToCharArray ac3 = sEnleverAccents.ToCharArray Dim sbDest As New StringBuilder For i = 0 To iLen - 1 If ac1(i) = ac2(i) Then sbDest.Append(ac3(i)) Else Select Case ac1(i) ' ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ Case "¤"c : sbDest.Append("o") Case "¦"c : sbDest.Append("|") Case "¨"c : sbDest.Append("..") Case "´"c : sbDest.Append("'") Case "¸"c : sbDest.Append(",") Case "¼"c : sbDest.Append("1/4") Case "½"c : sbDest.Append("1/2") Case "¾"c : sbDest.Append("3/4") Case "€"c : sbDest.Append("E") Case "Š"c : sbDest.Append("S") Case "š"c : sbDest.Append("s") Case "Ž"c : sbDest.Append("Z") Case "ž"c : sbDest.Append("z") Case "œ"c : sbDest.Append("oe") Case "Œ"c : sbDest.Append("OE") Case "Ÿ"c : sbDest.Append("Y") Case Else 'If bDebug Then Debug.WriteLine("?? : " & ac1(i) & ac2(i) & ac3(i)) sbDest.Append(ac1(i)) ' 22/05/2010 Laisser le car. si non trouvé End Select End If Next i sEnleverAccents = sbDest.ToString Fin: 'If bMinuscule Then sEnleverAccents = sEnleverAccents.ToLower End Function End Module modDepart.vb ' Fichier modDepart.vb : Module de départ ' -------------------- Module modDepart Public Const sNomAppli$ = "IAVB3" Public Const sTitreMsg$ = sNomAppli Public Const sDateVersionAppli$ = "18/06/2017" Public ReadOnly sVersionAppli$ = _ My.Application.Info.Version.Major & "." & _ My.Application.Info.Version.Minor & My.Application.Info.Version.Build #If DEBUG Then Public Const bDebug As Boolean = True 'Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False 'Public Const bRelease As Boolean = True #End If Public Sub Main() If bDebug Then Depart() : Exit Sub Try Depart() Catch ex As Exception AfficherMsgErreur(ex, "Main " & sTitreMsg) End Try End Sub Private Sub Depart() 'Dim bVoixActive As Boolean 'Dim bMSAgent As Boolean 'If Not Is64BitProcess() Then VerifierInstallAgent(bMSAgent, bVoixActive) Try Dim oFrm As New IAVB.frmIAVB 'oFrm.m_bMSAgent = bMSAgent 'oFrm.m_bVoixActive = bVoixActive ' ShowDialog ne fonctionne pas si la session n'est pas ouverte 'oFrm.ShowDialog() Application.Run(oFrm) Catch Ex As Exception AfficherMsgErreur(Ex, "Depart " & sTitreMsg) End Try End Sub End Module frmIAVB.vb ' Fichier frmIAVB.vb ' ------------------ Imports System.Collections.Generic Imports System.Speech Imports System.Speech.Synthesis Namespace IAVB Friend Class frmIAVB : Inherits Form #Region "Configuration" ' Booléen pour forcer le fonctionnement dans la version originale (1984) ' ou bien modifiée (2001) Private Const bVersionModifiee As Boolean = True ' True par défaut ' Normaliser les espaces et sauts de ligne en sortie Private Const bNormalisationSortieTrimEtVbLf As Boolean = True ' True par défaut ' Convertir tout en minuscules (pour éviter d'avoir à taper des majuscules avec accent, ' et pour pouvoir prononcer "ça" via MS-Agent) Private Const bTraiterEnMinuscules As Boolean = True ' True par défaut ' 29/04/2017 Enlever les accents (pour pouvoir comparer avec la version originale de 1984) Private Const bTraiterSansAccents As Boolean = False ' False par défaut #End Region #Region "Initialisations" Private Const iCodeToucheEntree% = 13 Private Const iNumLigneDebutExemples% = 8 ' Pour la démo sur les exemples Private m_bMSAgent As Boolean ' Pour pouvoir recopier la ligne ListIA dans la fonction RecopierLigneListIA Private m_bPositionnement As Boolean Private m_oIAVB As New IAVB.clsIAVB ' SpeechSynthesizer Class Provides access to the functionality of an installed a speech synthesis engine. Private WithEvents m_synth As New SpeechSynthesizer Const sVoixFR$ = "Microsoft Hortense Desktop" Const sVoix_enUSWin10$ = "Microsoft Zira Desktop" Const sVoix_enUSWin7$ = "Microsoft Anna" Const sFrancais$ = "Français (Hortense)" Const sAnglais$ = "Anglais (Zira)" Private m_sVoix$ = "" Const sModeVocalDef$ = sFrancais Const sModeSilencieux$ = "Silencieux" Const sModeMSAgent$ = "MS-Agent" Const iIndexModeSilencieux% = 0 'Const iIndexModeMSAgent% = 1 Dim iIndexModeSynthVocWin% = 2 Const sTxtCmdSuiv$ = "->" Const sMsgCmdSuiv$ = "Exemple suivant" Const sTxtCmdSuivStop$ = "St." Const sMsgCmdSuivStop$ = "Stop" Private Sub Initialisations() Dim sTxt$ = Me.Text & " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" If bDebug Then sTxt &= " - Debug" Dim b64 As Boolean = Is64BitProcess() If b64 Then sTxt &= " - 64 bits" Else sTxt &= " - 32 bits" Me.Text = sTxt Dim bVoixActive As Boolean If Not b64 Then VerifierInstallAgent(m_bMSAgent, bVoixActive) iIndexModeSynthVocWin = 1 Me.listParole.Items.Add(sModeSilencieux) If m_bMSAgent Then Me.listParole.Items.Add(sModeMSAgent) : iIndexModeSynthVocWin = 2 InitVoix() Me.listParole.SelectedIndex = iIndexModeSilencieux m_oIAVB.Initialiser(bVersionModifiee, bNormalisationSortieTrimEtVbLf, _ bTraiterEnMinuscules, bTraiterSansAccents) InitAssertionsExemples() End Sub Private Sub InitVoix() ' SpeechSynthesizer.GetInstalledVoices, méthode (CultureInfo) ' https://msdn.microsoft.com/fr-fr/library/ms586870(v=vs.110).aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1 ' Output information about all of the installed voices that ' support the en-US locacale. Dim dicoVoix As New Dictionary(Of String, VoiceInfo) For Each voix As InstalledVoice In m_synth.GetInstalledVoices() 'New CultureInfo("en-US")) Dim info As VoiceInfo = voix.VoiceInfo Dim sCle$ = info.Name & " (" & info.Culture.Name & ", " & info.Gender.ToString() & ")" ' Remplacer les noms des deux voix standards de Windows 10 par Français et Anglais If info.Name = sVoixFR Then sCle = sFrancais If info.Name = sVoix_enUSWin10 Then sCle = sAnglais If info.Name = sVoix_enUSWin7 Then sCle = sAnglais If Not dicoVoix.ContainsKey(sCle) Then dicoVoix.Add(sCle, info) Me.listParole.Items.Add(sCle) End If Next End Sub Private Sub listParole_SelectedIndexChanged(sender As Object, e As EventArgs) _ Handles listParole.SelectedIndexChanged If listParole.Text = sModeMSAgent Then If Not bInitMSAgent(m_bMSAgent, m_oIAVB.m_bVoixActive) Then listParole.Text = sModeSilencieux End If Else bMasquerMSAgent() End If If listParole.Text = sModeSilencieux Then m_oIAVB.m_bVoixActive = False Else m_oIAVB.m_bVoixActive = True End If If listParole.SelectedIndex >= iIndexModeSynthVocWin Then Dim sLangue$ = listParole.Text Dim sVoix$ = "" If sLangue = sFrancais Then sVoix = sVoixFR ElseIf sLangue = sAnglais Then sVoix = sVoix_enUSWin10 Else sVoix = sLangue Dim iPos% = sVoix.IndexOf("(") If iPos > -1 Then sVoix = sVoix.Substring(0, iPos - 1).Trim End If m_sVoix = sVoix End If End Sub Public Function bDire(sParole$) As Boolean If Me.listParole.Text = sModeMSAgent Then ' Les minuscules améliorent la prononciation des MS-Agent If m_bMSAgent AndAlso bTraiterEnMinuscules Then sParole = sParole.ToLower Return bDireMSAgent(sParole) End If If listParole.Text = sModeSilencieux Then Return False If Not IsNothing(m_synth) AndAlso m_sVoix.Length > 0 Then While m_synth.State = SynthesizerState.Speaking Attendre() End While If m_synth.State = SynthesizerState.Ready Then m_synth.SelectVoice(m_sVoix) Activation(bDesactiver:=True) 'm_synth.SpeakAsync(sParole) m_synth.Speak(sParole) ' Attendre la fin Activation() End If Else listParole.Text = sModeSilencieux End If Return True End Function ' Si SpeakAsync 'Private Sub MyEventHandler( eventSender As Object, _ ' eventArgs As SpeakCompletedEventArgs) Handles m_synth.SpeakCompleted ' Activation() 'End Sub Private Sub Activation(Optional bDesactiver As Boolean = False) ' Non, car on ne peut plus réactiver Me.chkAuto ou faire Stop 'Me.Enabled = bDesactiver Me.chkAuto.Enabled = True ' Tjrs actif Me.cmdSuivant.Enabled = True ' Tjrs actif (Stop le mode Auto) Me.listAssert.Enabled = Not bDesactiver Me.listIA.Enabled = Not bDesactiver Me.textInput.Enabled = Not bDesactiver Me.cmdGo.Enabled = Not bDesactiver Me.cmdInstall.Enabled = Not bDesactiver End Sub Private Sub AjouterExemple(sExemple$) Me.listAssert.Items.Add(sExemple) End Sub Private Sub InitAssertionsExemples() AjouterExemple(m_oIAVB.sCmdEffBase & " ' Effacer toute la base") AjouterExemple(m_oIAVB.sCmdEff & " ' Effacer la denière assertion") AjouterExemple(m_oIAVB.sCmdEff & "1 ' Effacer l'assertion n°1") AjouterExemple(m_oIAVB.sCmdLister & " ' Lister les assertions de la base") AjouterExemple(m_oIAVB.sCmdCopier & " ' Copier la discussion dans le presse papier") AjouterExemple(m_oIAVB.sCmdSilence & " ' Mettre en sourdine (autre poss.: masquer l'agent)") AjouterExemple(m_oIAVB.sCmdParler & " ' Ré-activer la voix") Dim lst As New List(Of String) Dim ex As New IAVB.clsInitIAVB(lst) ex.InitAssertionsExemples() For Each sExemple As String In lst AjouterExemple(sExemple) Next End Sub #End Region Private Sub TraiterCmd() Dim bMemVoixActive As Boolean = m_oIAVB.m_bVoixActive ' Eviter la réentrance dans les fonctions If m_oIAVB.m_bVoixActive Then Activation(bDesactiver:=True) ' Si la zone de saisie est multiligne, faire un Trim Dim sTxt$ = textInput.Text.Trim() m_oIAVB.IAVBMain(sTxt) If m_oIAVB.m_bCopierPressePapier Then If bCopierPressePapier(m_oIAVB.m_sDiscussion) Then m_oIAVB.CopiePressePapierOk() Else m_oIAVB.CopiePressePapierEchec() End If End If If Me.textInput.Text.Length = 0 Then Me.listIA.Items.Add("") PositionnerListIA() End If ' Activer ou réactiver la parole If Not bMemVoixActive AndAlso m_oIAVB.m_bVoixActive Then listParole.Text = sModeVocalDef Dim sReponseVocale$ = m_oIAVB.m_sReponseVocale If sReponseVocale.Length > 0 Then Dim asReponses$() = sReponseVocale.Split(vbLf.ToCharArray) Dim i% = 0 For Each sReponse As String In asReponses If sReponse.Trim.Length = 0 Then Continue For ' 12/05/2017 If i = 0 AndAlso asReponses.Length >= 1 AndAlso _ asReponses(1) = asReponses(0) Then ' Rappel de la question : dans ce cas on peut afficher le texte en 1er ' Réponse texte Me.listIA.Items.Add(sReponse) PositionnerListIA() bDire(sReponse) ' Réponse vocale ElseIf i = 1 AndAlso asReponses.Length >= 1 AndAlso _ asReponses(1) = asReponses(0) Then ' Déjà traité Else If i Mod 2 = 0 Then bDire(sReponse) ' Réponse vocale Else ' Réponse texte Me.listIA.Items.Add(sReponse) PositionnerListIA() End If End If i += 1 Next ' Désactiver la parole If Not m_oIAVB.m_bVoixActive Then listParole.Text = sModeSilencieux GoTo Fin End If If m_oIAVB.m_sRappelQuestion.Length > 0 Then Me.listIA.Items.Add(m_oIAVB.m_sRappelQuestion) PositionnerListIA() End If If m_oIAVB.m_sReponse.Length > 0 Then Dim asReponses$() = m_oIAVB.m_sReponse.Split(vbLf.ToCharArray) For Each sReponse As String In asReponses If sReponse.Trim.Length = 0 Then Continue For Me.listIA.Items.Add(sReponse) Next PositionnerListIA() End If Fin: If bMemVoixActive Then Activation() cmdSuivant.Focus() End If End Sub Private Sub RecopierLigneListIA() If Not m_bPositionnement Then textInput.Text = listIA.Text End Sub Public Sub PositionnerListIA() ' Toujours se positionner sur la dernière ligne m_bPositionnement = True listIA.SelectedIndex = listIA.Items.Count - 1 m_bPositionnement = False End Sub Private Sub TraiterAssertion() textInput.Text = listAssert.Text ' Veiller à ce que la question soit bien affichée avant d'activer la synthèse vocale TraiterMsgSysteme_DoEvents() TraiterCmd() End Sub Private Sub AssertionSuivante() If listAssert.SelectedIndex < iNumLigneDebutExemples Then listAssert.SelectedIndex = iNumLigneDebutExemples ElseIf listAssert.SelectedIndex < listAssert.Items.Count - 1 Then listAssert.SelectedIndex = listAssert.SelectedIndex + 1 End If TraiterAssertion() End Sub #Region "Gestion des événements" Private Sub frmIAVB_Load(eventSender As Object, eventArgs As EventArgs) Handles MyBase.Load Initialisations() End Sub Private Sub cmdGo_Click(eventSender As Object, eventArgs As EventArgs) Handles cmdGo.Click TraiterCmd() End Sub Private Sub chkAuto_Click(sender As Object, e As EventArgs) Handles chkAuto.Click If Me.chkAuto.Checked Then 'Me.cmdSuivant.Text = sTxtCmdSuivStop 'Me.ToolTip1.SetToolTip(Me.cmdSuivant, sMsgCmdSuivStop) Else Me.cmdSuivant.Text = sTxtCmdSuiv Me.ToolTip1.SetToolTip(Me.cmdSuivant, sMsgCmdSuiv) End If End Sub Private Sub cmdSuivant_Click(eventSender As Object, eventArgs As EventArgs) _ Handles cmdSuivant.Click Dim sMemAssertion2$, sMemAssertion$ sMemAssertion = "" Static bEnCours As Boolean = False If bEnCours Then GoTo Fin Recommencer: bEnCours = True sMemAssertion2 = sMemAssertion sMemAssertion = Me.listIA.Text.Trim AssertionSuivante() If Me.chkAuto.Checked Then Me.cmdSuivant.Text = sTxtCmdSuivStop Me.ToolTip1.SetToolTip(Me.cmdSuivant, sMsgCmdSuivStop) If Me.listIA.Text.Trim.Length = 0 AndAlso _ sMemAssertion.Length = 0 AndAlso sMemAssertion2.Length = 0 Then Me.textInput.Text = m_oIAVB.sCmdCopier ' "/C" TraiterCmd() bEnCours = False Exit Sub End If ' Voir si l'utilisateur à cliquer sur Stop TraiterMsgSysteme_DoEvents() GoTo Recommencer End If Fin: bEnCours = False Me.chkAuto.Checked = False Me.cmdSuivant.Text = sTxtCmdSuiv Me.ToolTip1.SetToolTip(Me.cmdSuivant, sMsgCmdSuiv) End Sub Private Sub ListAssert_SelectedIndexChanged(eventSender As Object, _ eventArgs As EventArgs) Handles listAssert.SelectedIndexChanged textInput.Text = listAssert.Text End Sub Private Sub ListAssert_DoubleClick(eventSender As Object, eventArgs As EventArgs) _ Handles listAssert.DoubleClick TraiterAssertion() End Sub Private Sub listIA_SelectedIndexChanged(eventSender As Object, eventArgs As EventArgs) _ Handles listIA.SelectedIndexChanged RecopierLigneListIA() End Sub Private Sub listIA_DoubleClick(eventSender As Object, eventArgs As EventArgs) _ Handles listIA.DoubleClick RecopierLigneListIA() TraiterCmd() End Sub Private Sub textInput_KeyPress(eventSender As Object, eventArgs As KeyPressEventArgs) _ Handles textInput.KeyPress Dim iCodeTouche% = Asc(eventArgs.KeyChar) If iCodeTouche = iCodeToucheEntree Then ' Touche Entrée TraiterCmd() Exit Sub End If End Sub Private Sub cmdInstall_Click(sender As Object, e As EventArgs) Handles cmdInstall.Click bInstallationMSAgent(m_bMSAgent, m_oIAVB.m_bVoixActive) End Sub #End Region End Class End Namespace modSynthVocaleMSAgent.vb ' Fichier modSynthVocale.vb : Module de synthèse vocale via MS-Agent ' ------------------------- Option Strict Off ' Liaison tardive ('On' possible en liaison anticipée) Module modSynthVocaleMSAgent #Region "Déclarations" ' Liaison anticipée : ajouter les références vers ' Interop.AgentObjects.dll et AxInterop.AgentObjects.dll 'Imports AgentObjects ' Pour Agent et IAgentCtlCharacter 'Private WithEvents m_oAgent As Agent ' WithEvents pour recevoir l'év. _RequestComplete 'Private m_oMerlin As IAgentCtlCharacter 'Private m_oMerlinRequest As IAgentCtlRequest ' Liaison tardive Private m_oAgent As Object Private m_oMerlin As Object Private Const sMSAgentCtrl2$ = "Microsoft Agent Control 2.0" Private Const sMSAgentCtrl2ProgID$ = "Agent.Control.2" 'Private Const sMSAgentCtrl2Ver$ = "2 du ??/??/???? : ? Ko" 'Private Const sMSAgentCtrl2Dll$ = "agentctl.dll" Private Const sMSAgentInst1Txt$ = "Microsoft Agent core components (MSagent.exe : 392 Ko)" Private Const sMSAgentInst1$ = "MSagent.exe" Private Const SMSAgentURL1$ = "http://activex.microsoft.com/activex/controls/agent2/MSagent.exe" Private Const sMSAgentInst2Txt$ = "Language component : French (AgtX040C.exe : 129 Ko)" Private Const sMSAgentInst2$ = "AgtX040C.exe" Private Const sMSAgentInst3Txt$ = "Character : Merlin (Merlin.exe : 1830 Ko)" Private Const sMSAgentInst3$ = "Merlin.exe" Private Const SMSAgentURL$ = "http://www.microsoft.com/msagent/downloads/user.aspx" Private Const sMSAgentACS$ = "merlin.acs" Private Const sSpeechAPI$ = "Microsoft Speech Object Library" 'Private Const sSpeechAPIProgID$ = "SAPI.SpLexicon.1" Private Const sSpeechAPIDll$ = "sapi.dll" Private Const sSpeechAPIInst$ = "spchapi.exe" Private Const sSpeechAPIInstTxt$ = "SAPI 4.0 runtime support" Private Const sSpeechAPI_URL$ = "http://activex.microsoft.com/activex/controls/sapi/spchapi.exe" Private Const sLHTTS3000Fr$ = "L&H TTS3000 Text-To-Speech - French" 'Private Const sLHTTS3000FrClsID$ = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" ' ClassID et non ProgID 'Private Const sLHTTS3000FrVer$ = "3000 du ??/??/???? : ? Ko" Private Const sLHTTS3000FrDll$ = "ttsFRFwr.dll" Private Const sLHTTS3000FrInst$ = "lhttsfrf.exe" Private Const sLHTTS3000FrInstTxt$ = "Lernout & Hauspie® TTS3000 TTS engine - French (2.2 MB exe)" #End Region #Region "Installation" Public Sub VerifierInstallAgent(ByRef bAgent As Boolean, ByRef bVoixActive As Boolean) bAgent = False bVoixActive = False If Not bVerifierInstallObjet(sMSAgentCtrl2ProgID) Then Exit Sub Dim sWinDir$ = sDossierParent(Environment.GetFolderPath( _ Environment.SpecialFolder.System)) Dim sCheminMerlin$ = sWinDir & "\msagent\chars\" & sMSAgentACS If bFichierExiste(sCheminMerlin) Then bAgent = True Dim bTTS_Ok As Boolean Dim sCheminTTS_LH$ = sWinDir & "\Lhsp\" & sLHTTS3000FrDll If bFichierExiste(sCheminTTS_LH) Then bTTS_Ok = True ' Si on désenregistre la dll et qu'on la supprime ' la classe est encore dans la BR : test non discriminant : ' simplement vérifier la présence de la dll 'If bVerifierInstallObjet(sLHTTS3000FrClsID, bClassID:=True) Then bTTS_Ok = True 'Dim bSAPI_Ok As Boolean 'Dim sFichiersCommuns$ = Environment.GetFolderPath( _ ' Environment.SpecialFolder.CommonProgramFiles) 'Dim sCheminSAPI$ = sFichiersCommuns & "\Microsoft Shared\Speech\" & sSpeechAPIDll 'If bFichierExiste(sCheminSAPI) Then bSAPI_Ok = True 'If bAgent And bTTS_Ok And bSAPI_Ok Then bVoixActive = True ' 01/05/2015 Plus besoin de SAPI avec Windows 7 64b ? If bAgent And bTTS_Ok Then bVoixActive = True End Sub Public Function bInstallationMSAgent( _ ByRef bMSAgent As Boolean, ByRef bVoixActive As Boolean) As Boolean bMSAgent = False bVoixActive = False If Not bVerifierInstallObjet(sMSAgentCtrl2ProgID) Then If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInst1, sMSAgentInst1Txt, SMSAgentURL1) Then GoTo MsgReinst If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInst2, sMSAgentInst2Txt, SMSAgentURL) Then GoTo MsgReinst GoTo MsgReinst End If Dim sWinDir$ = sDossierParent(Environment.GetFolderPath( _ Environment.SpecialFolder.System)) ' Si cette dernière étape est validée, alors MSAgent complètement installé 'C:\WINDOWS\msagent\chars\merlin.acs Dim sCheminMerlin$ = sWinDir & "\msagent\chars\" & sMSAgentACS If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInst3, sMSAgentInst3Txt, SMSAgentURL, sCheminMerlin) Then _ GoTo MsgReinst ' Reste la synthèse vocale (MS Agent peut être installé sans voix) Dim sCheminTTS_LH$ = sWinDir & "\Lhsp\" & sLHTTS3000FrDll If Not bVerifierDllActiveX_InstExe(sLHTTS3000Fr, "", _ sLHTTS3000FrInst, sLHTTS3000FrInstTxt, SMSAgentURL, sCheminTTS_LH, _ bClassID:=True) Then GoTo MsgReinst 'C:\Program Files\Fichiers communs\Microsoft Shared\Speech\sapi.dll Dim sFC$ = Environment.GetFolderPath( _ Environment.SpecialFolder.CommonProgramFiles) Dim sCheminSAPI$ = sFC & "\Microsoft Shared\Speech\" & sSpeechAPIDll ' 30/04/2017 Chemin plus récent Dim sWinSys$ = Environment.GetFolderPath(Environment.SpecialFolder.System) Dim sWinSysX86$ = Environment.GetFolderPath(Environment.SpecialFolder.SystemX86) Dim sCheminSapi32$ = sWinSysX86 & "\Speech\Common\sapi.dll" Dim sCheminSapi64$ = sWinSys & "\Speech\Common\sapi.dll" If bFichierExiste(sCheminSapi64) Then sCheminSAPI = sCheminSapi64 ElseIf bFichierExiste(sCheminSapi32) Then sCheminSAPI = sCheminSapi32 End If ' Simple vérification de la présence de la dll dans ce cas ' sLHTTS3000FrClsID If Not bVerifierDllActiveX_InstExe(sSpeechAPI, "", _ sSpeechAPIInst, sSpeechAPIInstTxt, sSpeechAPI_URL, sCheminSAPI) Then _ GoTo MsgReinst If Not bInitMSAgent(bMSAgent, bVoixActive) Then Return False Return True MsgReinst: MsgBox("Veuillez retester l'installation après l'installation du composant", _ MsgBoxStyle.Information, sTitreMsg) Return False End Function Public Function bInitMSAgent( _ ByRef bMSAgent As Boolean, ByRef bVoixActive As Boolean) As Boolean m_oAgent = Nothing m_oMerlin = Nothing Try If Not bCreerObjet(m_oAgent, sMSAgentCtrl2ProgID) Then Return False m_oAgent.Connected = True ' Nécessaire en DotNet ! Const sCleAgent$ = "Merlin" m_oAgent.Characters.Load(sCleAgent) ' On peut aussi préciser le fichier .acs : .Load("Merlin", "Merlin.acs") m_oMerlin = m_oAgent.Characters(sCleAgent) 'Dim iLangID% = m_oMerlin.LanguageID ' 1036 : Français m_oMerlin.Show() ' Zoom 2 'm_oMerlin.Height *= 2 'm_oMerlin.Width *= 2 bMSAgent = True bVoixActive = True Return True Catch ex As Exception AfficherMsgErreur(ex, "bInitMSAgent") Return False End Try End Function #End Region Public Function bMasquerMSAgent() As Boolean Try If IsNothing(m_oMerlin) Then Return False m_oMerlin.Hide() Return True Catch ex As Exception Return False End Try End Function Public Function bDireMSAgent(ByRef sParole$) As Boolean 'If Not glb1.bMSAgent Then Exit Function 'If Not glb1.bVoixActive Then Exit Function If m_oAgent Is Nothing Then Return False If m_oMerlin Is Nothing Then Return False Dim MerlinRequest As Object 'IAgentCtlRequest : Liaison anticipée MerlinRequest = m_oMerlin.Speak(sParole) ' Il faut pouvoir récupérer l'événement : compliqué 'm_oMerlin.Wait(MerlinRequest) ' Autre solution : récupérer l'événement m_oAgent_RequestComplete ' Autre solution : + simple Dim iStatut% = 0 ' 2 = pending, 4 = in progress Do iStatut = MerlinRequest.Status Application.DoEvents() Loop While iStatut = 2 Or iStatut = 4 bDireMSAgent = True End Function 'Private Sub m_oAgent_RequestComplete(oRequest As Object) ' ' ' Attendre que l'agent ait finit de parler pour écrire sa réponse ' If m_oMerlinRequest Is Nothing Then Exit Sub ' If oRequest <> m_oSpeakRequest Then Exit Sub ' ' Ecrire la réponse maintenant... ' 'End Sub End Module modUtil.vb ' Fichier modUtil.vb : Module de fonctions utilitaires ' --------------- Imports System.Text ' Pour Encoding Module modUtil Public Function Is64BitProcess() As Boolean Return (IntPtr.Size = 8) End Function Public Function bFichierExiste(sCheminFichier$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt bFichierExiste = IO.File.Exists(sCheminFichier) If Not bFichierExiste And bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable") End Function Public Function sDossierParent$(sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Sub OuvrirAppliAssociee(sCheminFichier$, _ Optional bMax As Boolean = False, _ Optional bVerifierFichier As Boolean = True) If bVerifierFichier Then ' Ne pas vérifier le fichier si c'est une URL à lancer If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub End If Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Function bVerifierDllActiveX_InstExe(sTitreComposant$, _ sClasseDllActiveX$, sExeInstall$, sTypeComposant$, _ sURLInst$, _ Optional sCheminFichierDoitExister$ = "", _ Optional sDossierInst$ = "\Installation", _ Optional bClassID As Boolean = False) As Boolean ' Vérifier et installer le cas échéant un composant Dll ActiveX via un exe Dim sTitreMsg$ = sNomAppli & " : Installation de " & sTitreComposant Dim bOk As Boolean = False If sCheminFichierDoitExister.Length > 0 Then If bFichierExiste(sCheminFichierDoitExister) Then bOk = True ElseIf bVerifierInstallObjet(sClasseDllActiveX, , bClassID) Then bOk = True End If If bOk Then MsgBox("Le composant [" & sTitreComposant & "] est bien installé.", _ MsgBoxStyle.Exclamation, sTitreMsg) bVerifierDllActiveX_InstExe = True Exit Function End If Dim sCheminExeInstall$ = Application.StartupPath & _ sDossierInst & "\" & sExeInstall Dim sMsg1$ = _ "Le composant " & sTitreComposant & vbLf & _ "n'est pas installé sur ce poste :" If Not bFichierExiste(sCheminExeInstall) Then If MsgBoxResult.Cancel = MsgBox( _ sMsg1 & vbLf & _ "Cliquez sur OK pour afficher la page de téléchargement :" & vbLf & _ sTypeComposant, _ MsgBoxStyle.Critical Or MsgBoxStyle.OkCancel, sTitreMsg) Then _ Application.Exit() : Return False OuvrirAppliAssociee(sURLInst, bVerifierFichier:=False) Return False End If If MsgBoxResult.Cancel = MsgBox(sMsg1 & vbLf & _ "Cliquez sur Ok pour installer ce composant :" & vbLf & _ sTypeComposant, _ vbOKCancel Or vbCritical, sTitreMsg) Then Return False OuvrirAppliAssociee(sCheminExeInstall) ' Poursuivre les autres installations Return True End Function Public Function bCleRegistreCRExiste(sCle$, _ Optional sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre Try ' This call goes to the Catch block if the registry key is not set. Dim rkCle As Microsoft.Win32.RegistryKey = _ Microsoft.Win32.Registry.ClassesRoot rkCle = rkCle.OpenSubKey(sCle & "\\" & sSousCle) If IsNothing(rkCle) Then Return False ' Si la version est présent, on devrait pouvoir l'obtenir ainsi : 'string[] aryTemp = rkCle.GetSubKeyNames(); 'string sVersion = aryTemp[0]; 'aryTemp = sVersion.Split('.'); 'iMajorVer = short.Parse(aryTemp[0] ,System.Globalization.NumberStyles.AllowHexSpecifier); 'iMinusVer = short.Parse(aryTemp[1] ,System.Globalization.NumberStyles.AllowHexSpecifier); Return True Catch Return False End Try End Function Public Sub AfficherMsgErreur(ByRef Ex As Exception, _ Optional sTitreFct$ = "", Optional sInfo$ = "", _ Optional sDetailMsgErr$ = "", _ Optional bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then bCopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Function bCopierPressePapier(sInfo$, Optional ByRef sMsgErr$ = "") As Boolean ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Return True Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur(ex, "CopierPressePapier", bCopierMsgPressePapier:=False, _ sMsgErrFinal:=sMsgErr) Return False End Try End Function Public Sub Attendre(Optional iMilliSec% = 200) Threading.Thread.Sleep(iMilliSec) End Sub Public Sub TraiterMsgSysteme_DoEvents() Application.DoEvents() End Sub End Module modUtilLT.vb ' Fichier modUtilLT.vb : Module de fonctions utilitaires en liaison tardive ' -------------------- Option Strict Off ' Pour oObjetQcq.Version Module modUtilLT ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bVerifierInstallObjet(sClasse$, _ Optional ByRef sVersion$ = "", _ Optional bClassID As Boolean = False, _ Optional bLireVersion As Boolean = False) As Boolean 'Optional ByRef sMajorVersion$ = "", _ 'Optional ByRef sMinorVersion$ = "" ' Vérifier si le composant est bien installé ' Pour les serveurs com/ActiveX mono-instance comme Outlook ' il faut utiliser une autre version qui teste GetObject avant ' CreateObject (sinon cette fonction risque de provoquer ' la fermeture du composant s'il est déjà ouvert) If bClassID Then ' Si c'est une ClassID au lieu d'un ProgID ' on lit simplement la clé If bCleRegistreCRExiste("TypeLib", sClasse) Then Return True Return False End If Dim oObjetQcq As Object = Nothing Try oObjetQcq = CreateObject(sClasse) ' sClasse = ProgID bVerifierInstallObjet = True Catch 'ex As Exception bVerifierInstallObjet = False End Try If bVerifierInstallObjet And bLireVersion Then Try sVersion = oObjetQcq.Version.ToString 'sVersion = CStr(oObjetQcq.Version) 'sMajorVersion = oObjetQcq.MajorVersion 'sMinorVersion = oObjetQcq.MinorVersion Catch End Try End If oObjetQcq = Nothing End Function Public Function bCreerObjet(ByRef oObjetQcq As Object, ByRef sClasse$) As Boolean ' Attention, avec Outlook, le CreateObject fait plutôt un GetObject ' (si l'appli était déjà ouverte, elle disparait), voir GetObject(, sClasse) Try oObjetQcq = CreateObject(sClasse) Return True Catch ex As Exception AfficherMsgErreur(ex, "bCreerObjet", "Classe de l'objet : " & sClasse) oObjetQcq = Nothing Return False End Try End Function End Module