AliceVB v1.0.1.*Table des procédures 1 - AssemblyInfo.vb 2 - frmAliceVB.vb 2.1 - Private Function bChargerFichiersAIML 2.2 - Private Function bInitRobot 2.3 - Private Function bQuitter 2.4 - Private Function bSauverSession 2.5 - Private Sub aboutToolStripMenuItem_Click 2.6 - Private Sub AfficherDerniereRq 2.7 - Private Sub AfficherDernierResultat 2.8 - Private Sub AfficherMsg 2.9 - Private Sub AfficherPrm 2.10 - Private Sub AfficherUtilisateur 2.11 - Private Sub buttonGo_Click 2.12 - Private Sub ChargerSession 2.13 - Private Sub exitToolStripMenuItem_Click 2.14 - Private Sub frmAliceVB_Activated 2.15 - Private Sub frmAliceVB_FormClosing 2.16 - Private Sub fromAIMLToolStripMenuItem_Click 2.17 - Private Sub fromDatFileToolStripMenuItem_Click 2.18 - Private Sub fromDefaultToolStripMenuItem_Click 2.19 - Private Sub InitialiserFrmAlice 2.20 - Private Sub InitMSAgent 2.21 - Private Sub licenseToolStripMenuItem_Click 2.22 - Private Sub menuDerniereRq_Click 2.23 - Private Sub menuDernierResultat_Click 2.24 - Private Sub menuMSAgent_Click 2.25 - Private Sub menuParametres_Click 2.26 - Private Sub menuParole_Click 2.27 - Private Sub menuUtilisateur_Click 2.28 - Private Sub menuVerifierMSAgent_Click 2.29 - Private Sub myBot_WrittenToLog 2.30 - Private Sub NoterQuestion 2.31 - Private Sub processInputFromUser 2.32 - Private Sub ReinitialisationToolStripMenuItem_Click 2.33 - Private Sub richTextBoxOutput_TextChanged 2.34 - Private Sub rtbQuestion_KeyDown 2.35 - Private Sub rtbQuestion_KeyPress 2.36 - Private Sub saveBotToolStripMenuItem_Click 2.37 - Private Sub singleFileToolStripMenuItem_Click 2.38 - Private Sub TimerInit_Tick 2.39 - Private Sub toolStripMenuItemCustomLib_Click 2.40 - Private Sub toolStripMenuItemLoadSession_Click 2.41 - Private Sub toolStripMenuItemSaveSession_Click 2.42 - Private Sub VerifierMSAgent 2.43 - Private Sub VerifierSynthVoc 2.44 - Public Sub Init 3 - modGlobal.vb 4 - ApplicationEvents.vb 4.1 - Private Sub MyApplication_Startup 5 - ViewInformation.vb 5.1 - Private Sub InitialiserFrm 5.2 - Private Sub InitializeComponent 5.3 - Protected Overrides Sub Dispose 5.4 - Public Sub New 5.5 - Public Sub New 5.6 - Public WriteOnly Property OutputMessage 6 - modMSAgent.vb 6.1 - Public Function bInitMSAgent 6.2 - Public Function bVerifierEtInstallerMSAgent 6.3 - Public Sub AfficherMSAgent 6.4 - Public Sub CacherMSAgent 6.5 - Public Sub Dire 6.6 - Public Sub VerifierInstallMSAgent 7 - modSynthVocale.vb 7.1 - Public Sub Dire2 8 - modUtilitaire.vb 8.1 - Public Function bCleRegistreCRExiste 8.2 - Public Function bVerifierDllActiveX_InstExe 8.3 - Public Sub AfficherMsgErreur2 8.4 - Public Sub CopierPressePapier 8.5 - Public Sub TraiterMsgSysteme_DoEvents 9 - modUtilLT.vb 9.1 - Public Function bCreerObjet 9.2 - Public Function bVerifierInstallObjet 10 - modUtilFichier.vb 10.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible 10.2 - Public Function asArgLigneCmd 10.3 - Public Function asLireFichier 10.4 - Public Function bAjouterFichier 10.5 - Public Function bAjouterFichier 10.6 - Public Function bChoisirFichier 10.7 - Public Function bCopierArbo 10.8 - Public Function bCopierFichier 10.9 - Public Function bDeplacerDossier 10.10 - Public Function bDeplacerFichiers2 10.11 - Public Function bDeplacerFichiers3 10.12 - Public Function bDossierExiste 10.13 - Public Function bEcrireFichier 10.14 - Public Function bEcrireFichier 10.15 - Public Function bFichierExiste 10.16 - Public Function bFichierExisteFiltre 10.17 - Public Function bFichierExisteFiltre2 10.18 - Public Function bReencoder 10.19 - Public Function bRenommerDossier 10.20 - Public Function bRenommerFichier 10.21 - Public Function bSupprimerDossier 10.22 - Public Function bSupprimerFichier 10.23 - Public Function bSupprimerFichiersFiltres 10.24 - Public Function bVerifierCreerDossier 10.25 - Public Function iNbFichiersFiltres% 10.26 - Public Function sbLireFichier 10.27 - Public Function sCheminRelatif$ 10.28 - Public Function sConvNomDos$ 10.29 - Public Function sDossierParent$ 10.30 - Public Function sEnleverSlashFinal$ 10.31 - Public Function sEnleverSlashInitial$ 10.32 - Public Function sExtraireChemin$ 10.33 - Public Function sFormaterNumerique$ 10.34 - Public Function sFormaterNumerique2$ 10.35 - Public Function sFormaterTailleOctets$ 10.36 - Public Function sLecteurDossier$ 10.37 - Public Function sLireFichier$ 10.38 - Public Function sNomDossierFinal$ 10.39 - Public Function sNomDossierParent$ 10.40 - Public Sub OuvrirAppliAssociee 10.41 - Public Sub ProposerOuvrirFichier AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("AliceVB")> <Assembly: AssemblyDescription( _ "AliceVB : Interface pour l'AIMLBot : Robot de discussion de type Alice d'après la source " & _ "AIMLBot Library de Nicholas H.Tollervey, www.ntoll.org et http://aimlbot.sourceforge.net")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("AliceVB")> <Assembly: AssemblyCopyright("© 2008 ORS Production")> <Assembly: AssemblyTrademark("AliceVB")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("1.0.1.*")> frmAliceVB.vb ' AliceVB : Interface pour l'AIMLBot : Robot de discussion de type Alice ' ---------------------------------------------------------------------- ' http://www.vbfrance.com/code.aspx?ID=1043 ' Documentation : alicechatbot.html : ' http://patrice.dargenton.free.fr/ia/alice/alicechatbot.html ' http://patrice.dargenton.free.fr/ia/alice/AliceVB.vbproj.html ' Version 1.01 du 07/09/2008 ' Par Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' ---------------------------------------------------------------------- ' AliceVB a été converti en VB depuis la source : ' ----------------------------------------------------------------- ' AIMLGUI is a simple interface for the AIMLBot library (Program#). ' (c) 2006 Nicholas H.Tollervey ' AIMLBot Library de Nicholas H.Tollervey 'http://ntoll.org/article/program-20 'http://www.ntoll.org ' Dernière version 2.5 du 09/04/2007 'http://aimlbot.sourceforge.net ' ----------------------------------------------------------------- ' 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) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' 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 ' ... ' ------------------------------------ ' Fichier frmAliceVB.vb : ' --------------------- Imports AIMLbot Imports AIMLbot.Utils Imports System Imports System.Drawing Imports System.IO Imports System.Text Imports System.Windows.Forms Public Class frmAliceVB #Region "Config" Private Const sNomFichierSessionUtilisateur$ = "UserSession.xml" Private sCheminSessionUtilisateur$ = Application.StartupPath & "\" & _ sNomFichierSessionUtilisateur 'http://aitools.org/Free_AIML_sets Private Const sSousDossierAiml$ = sSousDossierAiml_Anglais 'Private Const sSousDossierAiml$ = sSousDossierAiml_Francais Private Const sBonjour$ = "Hello" 'Private Const sBonjour$ = "Bonjour" #Region "Jeux aiml en anglais" Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_2006 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_2004 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_2005 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_Alice_2005 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_Alice_2002 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_Alice_2000 'Private Const sSousDossierAiml_Anglais$ = sSousDossierAiml_Anglais_AAA_2006 ' Program# - An AIML Chatterbot in C# ' http://ntoll.org/article/project-an-aiml-chatterbot-in-c ' http://ntoll.org/file_download/18 : AIMLBot.zip : Contient AIML.zip ' http://ntoll.org/file_download/19 : AIMLGui.zip ' AimlGUI version 1.0 du 21/02/2004 au 25/02/2004 (Contenu màj entre sept. 2003 et fev. 2004) ' 30128 catég. ' Pas de xsd, xsd deduit ok. ' Ne passe pas le schéma officiel Private Const sSousDossierAiml_Anglais_2004$ = "Anglais2004Stdr" ' 30134 catég. ' Fichiers présents dans le fichier AIMLGUI2.5.zip (2 fichiers en 2007) ' http://downloads.sourceforge.net/aimlbot/AIMLGUI2.5.zip ' Pas de xsd, sauf 1 : Salutations.aiml : xsd officiel, mais tous ne passent pas ! ' Ne passent pas le schéma officiel : Reduce, Computers, Client, Botmaster, Bot, Biography, Atomic, AI, That, Knowledge (test custom tag aussi) ' Solution : xsd déduit pour ceux là : ok ' 2 fichiers corrigés (petites erreurs) : money et stories Private Const sSousDossierAiml_Anglais_2006$ = "Anglais2006Stdr" ' Trop d'erreur (même au niveau xml), balise de départ <> : <alice> au lieu de <aiml> ' Pas de schéma, mais si on conserve uniquement les aiml sans err ' on peut extraire un schéma pour le comparer aux autres Private Const sSousDossierAiml_Anglais_Alice_2000$ = "Alice-2000-ActiveX" 'Richard Wallace's A.L.I.C.E. : 23/05/2002 : pas de xsd, xsd deduit ok sans pb ' Ne passe pas le schéma officiel 'http://www.alicebot.org/aiml/alice.zip ' 41122 catég., pas d'erreur Private Const sSousDossierAiml_Anglais_Alice_2002$ = "Alice-2002" ' A.L.I.C.E. ' Mélange de français, allemand et anglais !!! ' Il parle français, mais il ne fait que répondre oui à la question ' puis revient en anglais... peut etre xml pas adapté ' il y a des avertissements selon le xsd officiel référencé ' Pas réussit à déduire un schéma sans err : cf. AAA ' 41122 catég., pas d'erreur ' boucle infinie parfois en français ! 'http://aitools.org/aiml-sets/alice-2005-05-14.zip Private Const sSousDossierAiml_Anglais_Alice_2005$ = "Alice-2005-05-14" 'Annotated A.L.I.C.E. http://www.alicebot.org/aiml/aaa/ ' 47182 catég ' Il y a des erreurs selon le xsd officiel référencé (mais semble marcher) ' Badanswer et Integer.aiml n'ont pas de schéma ' Pas réussit à déduire un schéma sans err car ou bien on enlève le schéma et on obtient : ' <html:br/> : Le préfixe du nom d'espaces 'html' n'est pas défini. ' ou bien on laisse le schéma et on obtient : ' Impossible de trouver les informations de schéma pour l'élément 'http://www.w3.org/1999/xhtml:br'. 'http://aitools.org/aiml-sets/aaa/aaa-2006-05-11.tar.gz Private Const sSousDossierAiml_Anglais_AAA_2006$ = "AAA-2006-05-11" ' 23811 catég., 4 warning au dém., Boucle infinie pour certaines réponses ! (simple Hello) ' Il y a des erreurs selon le xsd officiel référencé ' Pas réussit à déduire un schéma sans err : cf. AAA 'http://aitools.org/aiml-sets/standard-AIML-2005-05-14.zip Private Const sSousDossierAiml_Anglais_2005$ = "Anglais-2005-05-14" #End Region #Region "Jeux aiml en français" Private Const sSousDossierAiml_Francais$ = sSousDossierAiml_Fr2003JLC 'Private Const sSousDossierAiml_Francais$ = sSousDossierAiml_Fr2005TSL 'Private Const sSousDossierAiml_Francais$ = sSousDossierAiml_Fr2005JLC 'Private Const sSousDossierAiml_Francais$ = sSousDossierAiml_Fr2006TSL ' 47590 catég. ' Pas d'err au chargement, mais des parasites dans les réponses : ' You: Bonjour ' Bot: idFace = "".Salut Patrice! ' Pas de xsd, date indiquée entre le 10/04/2002 et le 22/01/2003 ' Un car. unicode (Plôme... dans humour.aiml), possible de déduire un xsd valable ' Fichier apparence.aiml corrigé 'www.alicebot.org/downloads/aiml/aiml-std-fr.zip daté du 31/01/2003 Private Const sSousDossierAiml_Fr2003JLC$ = "Francais2003JeanLouisCampion" ' 39206 catég. ' Pas d'err au chargement, mais des parasites dans les réponses : ' You: Bonjour ' Bot: window.open('.gif', 'facesrc', 'width=311,height=223');.Salut Patrice! ' apparence.aiml a un pb d'encodage : corrigé ' date indiquée entre le 09/04/2002 et le 23/08/2002 ' Il y a des erreurs selon le xsd officiel référencé ' Impossible de déduire un xsd sans err : même pb que pour AAA-2006-05-11 'http://aitools.org/aiml-sets/FrenchAIML-2005-05-14.zip Private Const sSousDossierAiml_Fr2005JLC$ = "Francais2005JeanLouisCampion" ' xsd officiel ! mais non conforme ! (srai_ed, quel_ed, comment_ed, atomique_ed) ' en fait même date indiquée du 08 Dec 2005, seul le fichier srai_ed semble <> 'http://aitools.org/aiml-sets/FrenchAIML-2006-03-06.zip ' Impossible de déduire un xsd sans err. : meme pb que AAA-2006-05-11 ' Si on utilise le xsd déduit de Anglais2006Stdr : il y a des erreurs ' fichiers aiml incomplet, a utiliser en complément de CumulFrancais2005JLC.aiml ? ' 12723 catég. ' You: Bonjour ' The bot could not find any response for the input: ' Bonjour with the path(s): Bonjour <that> * <topic> * from the user with an id: DefaultUser ' un des fichiers aiml contient un caractère unicode (utf-16) : impossible de le sauver en iso-8859-1 ' pourtant le cumul s'affiche bien sous IE sans err Private Const sSousDossierAiml_Fr2006TSL$ = "Francais2006TanSiewLan" ' 12723 catég., 12 fichiers : datés du 03/01/2003, mais ' date indiquée dans le contenu xml : 08/12/2005 : forcément antidatée ! 'www.alicebot.org/downloads/aiml/french_aiml_publish.zip ' Pas de xsd, xsd déduit ok (contrairement à 2006TSL) mais <> de l'anglais stdr ' Pareil que 2006TSL : complément ' On peut faire un cumul Fr2003JLC+2005TSL et deduire un xsd valide Private Const sSousDossierAiml_Fr2005TSL$ = "Francais2005TanSiewLan" #End Region #End Region #Region "Déclarations" Private m_bMSAgentInit As Boolean Private m_bFrancais As Boolean Private m_bQuestionSauverSession As Boolean Private lastRequest As Request = Nothing Private lastResult As Result = Nothing Private myBot As Bot Private myUser As User Private m_bInit As Boolean Private m_iNumQuestion% Private m_alQuestions As New ArrayList ' Conserver l'ordre Private m_htQuestions As New Hashtable ' Ne pas sauver une question plusieurs fois Private m_frmRq, m_frmRes, m_frmPrm, m_frmUtilisateur As ViewInformation #End Region #Region "Initialisation" Private Sub InitialiserFrmAlice() ' Reprendre la taille et la position précédente de la fenêtre ' Note : l'appel à InitialiserFrmAlice() se trouve dans la fonction frmAliceVB.Designer.New() ' Positionnement de la fenêtre par le code : mode manuel Me.StartPosition = FormStartPosition.Manual ' Fixer la position et la taille de la feuille sauvées dans le fichier .exe.config Me.Location = My.Settings.frmAlice_Pos Me.Size = My.Settings.frmAlice_Taille End Sub Private Sub frmAliceVB_Activated(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Activated If Me.m_bInit Then Exit Sub Me.m_bInit = True Me.TimerInit.Interval = 100 Me.TimerInit.Start() End Sub Private Sub TimerInit_Tick(ByVal sender As Object, ByVal e As EventArgs) _ Handles TimerInit.Tick Me.TimerInit.Stop() Init() End Sub Public Sub Init() Me.m_bFrancais = True If sSousDossierAiml = sSousDossierAiml_Anglais Then Me.m_bFrancais = False Me.menuMSAgent.Checked = False Me.menuParole.Checked = False If My.Settings.bActiverMSAgent Then Dim bMSAgent, bVoixActive As Boolean VerifierInstallMSAgent(bMSAgent, bVoixActive, Me.m_bFrancais) Me.menuMSAgent.Checked = bMSAgent Me.menuParole.Checked = bVoixActive If bMSAgent Then InitMSAgent() ElseIf My.Settings.bActiverParole Then VerifierSynthVoc() End If Me.menuDerniereRq.Checked = My.Settings.bAfficherRq Me.menuDernierResultat.Checked = My.Settings.bAfficherResultat Me.menuUtilisateur.Checked = My.Settings.bAfficherInfoUtilisateur Me.menuParametres.Checked = My.Settings.bAfficherPrm If Not bInitRobot() Then Exit Sub If Not bChargerFichiersAIML() Then Exit Sub If bFichierExiste(sCheminSessionUtilisateur) Then ChargerSession(sCheminSessionUtilisateur) End If If My.Settings.bAfficherInfoUtilisateur Then AfficherUtilisateur() If My.Settings.bAfficherPrm Then AfficherPrm() If bDebug Then Me.rtbQuestion.Text = sBonjour End If Me.rtbQuestion.Focus() End Sub Private Sub AfficherMsg(ByVal sMsg$) Me.richTextBoxOutput.AppendText(sMsg & Environment.NewLine) Me.richTextBoxOutput.ScrollToCaret() End Sub Private Function bInitRobot() As Boolean Me.myBot = New Bot ' Mettre plutôt le dossier Config avec les différents Aiml 'Me.myBot.loadSettings() Dim sDossierCourant$ = Application.StartupPath 'Environment.CurrentDirectory Const sDossierAiml$ = "Aiml" Const sDossierConfig$ = "Config" Const sFichierConfig$ = "Settings.xml" Dim sCheminConfig$ = Path.Combine(sDossierCourant, sDossierAiml) sCheminConfig = Path.Combine(sCheminConfig, sSousDossierAiml) sCheminConfig = Path.Combine(sCheminConfig, sDossierConfig) sCheminConfig = Path.Combine(sCheminConfig, sFichierConfig) If Not bFichierExiste(sCheminConfig, bPrompt:=True) Then Exit Function Me.myBot.loadSettings(sCheminConfig) Me.myUser = New User("DefaultUser", Me.myBot) 'MsgBox(Me.myUser.UserID & ":" & Me.myUser.ToString)' & ":" & Me.myUser.LastResult.ToString) AddHandler Me.myBot.EvWrittenToLog, New AIMLbot.Bot.LogMessageDelegate( _ AddressOf Me.myBot_WrittenToLog) bInitRobot = True AfficherMsg("") AfficherMsg("Le robot a été initialisé avec succès !") End Function Private Function bChargerFichiersAIML() As Boolean Try Dim loader As New AIMLLoader(Me.myBot) Me.myBot.isAcceptingUserInput = False loader.loadAIML(Me.myBot.PathToAIML) Me.myBot.isAcceptingUserInput = True bChargerFichiersAIML = True AfficherMsg("Les fichiers AIML ont été chargés avec succès !") Catch ex As Exception AfficherMsg(ex.Message) End Try End Function Private Sub ChargerSession(ByVal sCheminSessionUtilisateur$) Me.myUser.Predicates.loadSettings(sCheminSessionUtilisateur) AfficherMsg("La session utilisateur a été chargée avec succès !") End Sub Private Function bSauverSession(ByVal sCheminSessionUtilisateur$) As Boolean Try Me.myUser.Predicates.DictionaryAsXML.Save(sCheminSessionUtilisateur) AfficherMsg("La session utilisateur a été sauvegardée avec succès !") bSauverSession = True Catch ex As Exception AfficherMsg(ex.Message) End Try End Function Private Function bQuitter() As Boolean Dim iReponse% = MessageBox.Show( _ "Voulez-vous sauver la session utilisateur ?", _ "Quitter l'application", _ MessageBoxButtons.YesNoCancel, MessageBoxIcon.Question) If iReponse = DialogResult.Cancel Then Exit Function If iReponse = DialogResult.No Then GoTo Fin If Not bSauverSession(sCheminSessionUtilisateur) Then Exit Function Fin: m_bQuestionSauverSession = True bQuitter = True End Function Private Sub frmAliceVB_FormClosing(ByVal sender As Object, _ ByVal e As Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing ' Sauver la configuration (emplacement de la fenêtre) dans le fichier .exe.config ' Proposer de sauver la session If Not m_bQuestionSauverSession AndAlso Not bQuitter() Then e.Cancel = True : Exit Sub ' Le fichier sera sauvé ici : '\Documents and Settings\<utilisateur>\Local Settings\Application Data\ ' ORS_Production\AliceVB.exe_Url_xxx...xxx\1.0.1.xxxxx\user.config My.Settings.bActiverParole = Me.menuParole.Checked My.Settings.bActiverMSAgent = Me.menuMSAgent.Checked My.Settings.bAfficherRq = Me.menuDerniereRq.Checked My.Settings.bAfficherResultat = Me.menuDernierResultat.Checked My.Settings.bAfficherPrm = Me.menuParametres.Checked My.Settings.bAfficherInfoUtilisateur = Me.menuUtilisateur.Checked If Me.WindowState <> FormWindowState.Maximized Then My.Settings.frmAlice_Pos = Me.Location My.Settings.frmAlice_Taille = Me.Size End If If My.Settings.bAfficherRq And Not IsNothing(Me.m_frmRq) AndAlso _ Me.m_frmRq.WindowState <> FormWindowState.Maximized Then My.Settings.frmRq_Pos = Me.m_frmRq.Location My.Settings.frmRq_Taille = Me.m_frmRq.Size End If If My.Settings.bAfficherResultat And Not IsNothing(Me.m_frmRes) AndAlso _ Me.m_frmRes.WindowState <> FormWindowState.Maximized Then My.Settings.frmRes_Pos = Me.m_frmRes.Location My.Settings.frmRes_Taille = Me.m_frmRes.Size End If If My.Settings.bAfficherPrm And Not IsNothing(Me.m_frmPrm) AndAlso _ Me.m_frmPrm.WindowState <> FormWindowState.Maximized Then My.Settings.frmPrm_Pos = Me.m_frmPrm.Location My.Settings.frmPrm_Taille = Me.m_frmPrm.Size End If If My.Settings.bAfficherInfoUtilisateur And _ Not IsNothing(Me.m_frmUtilisateur) AndAlso _ Me.m_frmUtilisateur.WindowState <> FormWindowState.Maximized Then My.Settings.frmUtilisateur_Pos = Me.m_frmUtilisateur.Location My.Settings.frmUtilisateur_Taille = Me.m_frmUtilisateur.Size End If End Sub Private Sub VerifierMSAgent() If bVerifierEtInstallerMSAgent(Me.m_bFrancais) Then Exit Sub ' Voir ce qui ne marche pas précisément Dim bMSAgent, bVoixActive As Boolean VerifierInstallMSAgent(bMSAgent, bVoixActive, Me.m_bFrancais) If Not bMSAgent Then Me.menuMSAgent.Checked = False If Not bVoixActive Then Me.menuParole.Checked = False End Sub Private Sub InitMSAgent() Dim bVoixMSAgentPossible As Boolean m_bMSAgentInit = bInitMSAgent(bVoixMSAgentPossible, m_bFrancais) If Not m_bMSAgentInit Then Me.menuMSAgent.Checked = False If Not bVoixMSAgentPossible Then Me.menuParole.Checked = False End Sub Private Sub VerifierSynthVoc() ' Vérifier que la dll est présente Dim sCheminDllSynthVoc$ = Application.StartupPath & "\" & sNomDllSynthVoc If Not bFichierExiste(sCheminDllSynthVoc, bPrompt:=True) Then Me.menuParole.Checked = False End If End Sub #End Region #Region "Gestion du robot" Private Sub buttonGo_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles buttonGo.Click Me.processInputFromUser() End Sub Private Sub myBot_WrittenToLog() AfficherMsg(Me.myBot.LastLogMessage) End Sub Private Sub NoterQuestion(ByVal sQuestion$) If Me.m_htQuestions.ContainsKey(sQuestion) Then Exit Sub Me.m_htQuestions.Add(sQuestion, sQuestion) Me.m_alQuestions.Add(sQuestion) Me.m_iNumQuestion = Me.m_alQuestions.Count End Sub Private Sub rtbQuestion_KeyDown(ByVal sender As Object, _ ByVal e As Windows.Forms.KeyEventArgs) Handles rtbQuestion.KeyDown If Me.m_alQuestions.Count = 0 Then Exit Sub If e.KeyCode = Keys.Up Then Me.m_iNumQuestion -= 1 ElseIf e.KeyCode = Keys.Down Then Me.m_iNumQuestion += 1 Else Exit Sub End If If Me.m_iNumQuestion >= Me.m_alQuestions.Count Then Me.m_iNumQuestion = Me.m_alQuestions.Count - 1 Exit Sub End If If Me.m_iNumQuestion < 0 Then Me.m_iNumQuestion = 0 End If Me.rtbQuestion.Text = CStr(Me.m_alQuestions(Me.m_iNumQuestion)) End Sub Private Sub rtbQuestion_KeyPress(ByVal sender As Object, _ ByVal e As KeyPressEventArgs) Handles rtbQuestion.KeyPress If e.KeyChar = vbCr Then Me.processInputFromUser() End If End Sub Private Sub richTextBoxOutput_TextChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles richTextBoxOutput.TextChanged Me.richTextBoxOutput.ScrollToCaret() End Sub Private Sub processInputFromUser() If Me.myBot.isAcceptingUserInput Then Dim sQuestion$ = Me.rtbQuestion.Text If sQuestion.Trim.Length = 0 Then Exit Sub AfficherMsg("You: " & sQuestion.Trim) ' Noter les questions pour les rappeler via les touches flèche haut et bas NoterQuestion(sQuestion.Trim) Me.rtbQuestion.Text = String.Empty Dim myRequest As New Request(sQuestion, Me.myUser, Me.myBot) Dim myResult As Result = Me.myBot.Chat(myRequest) Me.lastRequest = myRequest Me.lastResult = myResult If Me.menuMSAgent.Checked Then ' Mode synthèse vocale via les MS-Agents Dire(myResult.Output, bSilencieux:=Not Me.menuParole.Checked) ElseIf Me.menuParole.Checked Then ' Mode synthèse vocale sans les MS-Agents Dire2(myResult.Output) End If AfficherMsg("Bot: " & myResult.Output) Else AfficherMsg("Bot not accepting user input.") End If If Me.menuDerniereRq.Checked Then AfficherDerniereRq() If Me.menuDernierResultat.Checked Then AfficherDernierResultat() If Me.menuParametres.Checked Then AfficherPrm() If Me.menuUtilisateur.Checked Then AfficherUtilisateur() Me.Focus() End Sub Private Sub AfficherDernierResultat() If Not Me.menuDernierResultat.Checked And Not IsNothing(Me.m_frmRes) Then Me.m_frmRes.Close() Me.m_frmRes = Nothing Exit Sub End If If IsNothing(Me.lastResult) Then Exit Sub Dim sb As New StringBuilder sb.Append("Last Result:" & vbLf & vbLf) sb.Append("Raw Input: " & Me.lastResult.RawInput & vbLf) sb.Append("Output: " & Me.lastResult.Output & vbLf) sb.Append("Raw Output: " & Me.lastResult.RawOutput & vbLf) sb.Append("Duration: " & Me.lastResult.Duration.ToString & _ vbLf & vbLf) sb.Append("Sentences: " & vbLf) Dim sentence As String For Each sentence In Me.lastResult.InputSentences sb.Append(sentence & vbLf) Next sb.Append(vbLf) sb.Append(vbLf) sb.Append("Sub Queries: " & vbLf) sb.Append(vbLf) Dim query As SubQuery For Each query In Me.lastResult.SubQueries sb.Append("Path: " & query.FullPath & vbLf) sb.Append("Template: " & vbLf & query.Template & vbLf) sb.Append(vbLf) sb.Append("Input Stars:" & vbLf) Dim star As String For Each star In query.InputStar sb.Append(star & vbLf) Next sb.Append(vbLf) sb.Append("That Stars:" & vbLf) Dim that As String For Each that In query.ThatStar sb.Append(that & vbLf) Next sb.Append(vbLf) sb.Append("Topic Stars:" & vbLf) Dim topic As String For Each topic In query.TopicStar sb.Append(topic & vbLf) Next sb.Append(vbLf) Next sb.Append(vbLf) sb.Append("Output Sentences: " & vbLf) Dim outputSentence As String For Each outputSentence In Me.lastResult.OutputSentences sb.Append(outputSentence & vbLf) Next If Not IsNothing(Me.m_frmRes) Then My.Settings.frmRes_Pos = Me.m_frmRes.Location My.Settings.frmRes_Taille = Me.m_frmRes.Size Me.m_frmRes.Close() End If Me.m_frmRes = New ViewInformation("Résultats", _ My.Settings.frmRes_Pos, My.Settings.frmRes_Taille) Me.m_frmRes.OutputMessage = sb.ToString Me.m_frmRes.Show() End Sub Private Sub AfficherDerniereRq() If Not Me.menuDerniereRq.Checked And Not IsNothing(Me.m_frmRq) Then Me.m_frmRq.Close() Me.m_frmRq = Nothing Exit Sub End If If IsNothing(Me.lastRequest) Then Exit Sub Dim sb As New StringBuilder sb.Append("Last Request:" & vbLf & vbLf) sb.Append("Raw Input: " & Me.lastRequest.rawInput.Replace(vbLf, "") & vbLf) sb.Append("Started On: " & Me.lastRequest.StartedOn & vbLf) sb.Append("Has Timed Out: " & _ Convert.ToString(Me.lastRequest.hasTimedOut) & vbLf & vbLf) If Not IsNothing(Me.m_frmRq) Then My.Settings.frmRq_Pos = Me.m_frmRq.Location My.Settings.frmRq_Taille = Me.m_frmRq.Size Me.m_frmRq.Close() End If Me.m_frmRq = New ViewInformation("Dernière requête", _ My.Settings.frmRq_Pos, My.Settings.frmRq_Taille) Me.m_frmRq.OutputMessage = sb.ToString Me.m_frmRq.Show() End Sub Private Sub AfficherPrm() If Not Me.menuParametres.Checked And Not IsNothing(Me.m_frmPrm) Then Me.m_frmPrm.Close() Me.m_frmPrm = Nothing Exit Sub End If Dim sb As New StringBuilder sb.Append(("Bot Settings:" & Environment.NewLine & Environment.NewLine)) Dim setting As String For Each setting In Me.myBot.GlobalSettings.SettingNames sb.Append(setting & ": " & Me.myBot.GlobalSettings.grabSetting(setting) & _ Environment.NewLine) Next ' Ajouter d'autre info. sb.Append(vbCrLf) sb.Append("frmAlice_X : " & Me.Location.X & vbCrLf) sb.Append("frmAlice_Y : " & Me.Location.Y & vbCrLf) sb.Append("frmAlice_L : " & Me.Size.Width & vbCrLf) sb.Append("frmAlice_H : " & Me.Size.Height & vbCrLf) If Not IsNothing(Me.m_frmPrm) Then My.Settings.frmPrm_Pos = Me.m_frmPrm.Location My.Settings.frmPrm_Taille = Me.m_frmPrm.Size Me.m_frmPrm.Close() End If Me.m_frmPrm = New ViewInformation("Paramètres", _ My.Settings.frmPrm_Pos, My.Settings.frmPrm_Taille) Me.m_frmPrm.OutputMessage = sb.ToString Me.m_frmPrm.Show() End Sub Private Sub AfficherUtilisateur() If Not Me.menuUtilisateur.Checked And Not IsNothing(Me.m_frmUtilisateur) Then Me.m_frmUtilisateur.Close() Me.m_frmUtilisateur = Nothing Exit Sub End If Dim sb As New StringBuilder sb.Append("User Information:" & Environment.NewLine & Environment.NewLine) sb.Append("UserID: " & Me.myUser.UserID & Environment.NewLine) sb.Append("Topic: " & Me.myUser.Topic & Environment.NewLine & Environment.NewLine) sb.Append("User Predicate List:" & Environment.NewLine) Dim setting As String For Each setting In Me.myUser.Predicates.SettingNames sb.Append(setting & ": " & Me.myUser.Predicates.grabSetting(setting) & _ Environment.NewLine) Next If Not IsNothing(Me.m_frmUtilisateur) Then My.Settings.frmUtilisateur_Pos = Me.m_frmUtilisateur.Location My.Settings.frmUtilisateur_Taille = Me.m_frmUtilisateur.Size Me.m_frmUtilisateur.Close() End If Me.m_frmUtilisateur = New ViewInformation("Utilisateur", _ My.Settings.frmUtilisateur_Pos, My.Settings.frmUtilisateur_Taille) Me.m_frmUtilisateur.OutputMessage = sb.ToString Me.m_frmUtilisateur.Show() End Sub #End Region #Region "Gestion des menus" Private Sub menuMSAgent_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuMSAgent.Click Me.menuMSAgent.Checked = Not Me.menuMSAgent.Checked If Me.menuMSAgent.Checked Then InitMSAgent() ElseIf Me.menuParole.Checked Then VerifierSynthVoc() End If If Not m_bMSAgentInit Then Exit Sub If Me.menuMSAgent.Checked Then AfficherMSAgent() Else CacherMSAgent() End If End Sub Private Sub menuParole_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuParole.Click Me.menuParole.Checked = Not Me.menuParole.Checked If Not Me.menuParole.Checked Then Exit Sub If Not Me.menuMSAgent.Checked Then VerifierSynthVoc() End If End Sub Private Sub menuVerifierMSAgent_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuVerifierMSAgent.Click VerifierMSAgent() End Sub Private Sub exitToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles exitToolStripMenuItem.Click If bQuitter() Then Application.Exit() End Sub Private Sub fromAIMLToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles fromAIMLToolStripMenuItem.Click Try Me.folderBrowserDialogAIML.RootFolder = Environment.SpecialFolder.MyComputer Me.folderBrowserDialogAIML.SelectedPath = Me.myBot.PathToAIML If (Me.folderBrowserDialogAIML.ShowDialog(Me) = DialogResult.OK) Then Dim loader As New AIMLLoader(Me.myBot) Me.myBot.isAcceptingUserInput = False If (Me.folderBrowserDialogAIML.SelectedPath.Length > 0) Then loader.loadAIML(Me.folderBrowserDialogAIML.SelectedPath) Else loader.loadAIML(Me.myBot.PathToAIML) End If Me.myBot.isAcceptingUserInput = True AfficherMsg("Les fichiers AIML personnalisés ont été chargés avec succès !") End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub fromDatFileToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles fromDatFileToolStripMenuItem.Click Try Dim fi As New FileInfo(Application.ExecutablePath) Me.openFileDialogDump.InitialDirectory = fi.DirectoryName Me.openFileDialogDump.AddExtension = True Me.openFileDialogDump.DefaultExt = "dat" Me.openFileDialogDump.FileName = "Graphmaster.dat" If (Me.openFileDialogDump.ShowDialog(Me) = DialogResult.OK) Then Me.myBot.isAcceptingUserInput = False Me.myBot.loadFromBinaryFile(Me.openFileDialogDump.FileName) Me.myBot.isAcceptingUserInput = True AfficherMsg("Le fichier de donnée a été chargé avec succès !") End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub fromDefaultToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles fromDefaultToolStripMenuItem.Click Try Dim loader As New AIMLLoader(Me.myBot) Me.myBot.isAcceptingUserInput = False loader.loadAIML(Me.myBot.PathToAIML) Me.myBot.isAcceptingUserInput = True AfficherMsg("Les fichiers AIML par défaut ont été chargés avec succès !") Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub menuDerniereRq_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuDerniereRq.Click AfficherDerniereRq() End Sub Private Sub menuDernierResultat_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuDernierResultat.Click AfficherDernierResultat() End Sub Private Sub menuParametres_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuParametres.Click AfficherPrm() End Sub Private Sub menuUtilisateur_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles menuUtilisateur.Click AfficherUtilisateur() End Sub Private Sub saveBotToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles saveBotToolStripMenuItem.Click Try Dim fi As New FileInfo(Application.ExecutablePath) Me.saveFileDialogDump.InitialDirectory = fi.DirectoryName Me.saveFileDialogDump.AddExtension = True Me.saveFileDialogDump.DefaultExt = "dat" Me.saveFileDialogDump.FileName = "Graphmaster.dat" If ((Me.saveFileDialogDump.ShowDialog(Me) = DialogResult.OK) AndAlso _ (Me.myBot.Size > 0)) Then Me.myBot.isAcceptingUserInput = False Me.myBot.saveToBinaryFile(Me.saveFileDialogDump.FileName) Me.myBot.isAcceptingUserInput = True AfficherMsg("Le robot a été sauvegardé avec succès !") End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub singleFileToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles singleFileToolStripMenuItem.Click Try Dim fi As New FileInfo(Path.Combine(Application.ExecutablePath, "aiml")) Me.openFileDialogDump.InitialDirectory = fi.DirectoryName Me.openFileDialogDump.AddExtension = True Me.openFileDialogDump.DefaultExt = "aiml" Me.openFileDialogDump.FileName = "Reduce.aiml" If (Me.openFileDialogDump.ShowDialog(Me) = DialogResult.OK) Then Dim loader As New AIMLLoader(Me.myBot) Me.myBot.isAcceptingUserInput = False loader.loadAIMLFile(Me.openFileDialogDump.FileName) Me.myBot.isAcceptingUserInput = True AfficherMsg("Le fichiers AIML a été chargé avec succès !") End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub toolStripMenuItemCustomLib_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles toolStripMenuItemCustomLib.Click Try Dim fi As New FileInfo(Application.ExecutablePath) Me.openFileDialogDump.InitialDirectory = fi.DirectoryName Me.openFileDialogDump.AddExtension = True Me.openFileDialogDump.DefaultExt = "dll" If ((Me.openFileDialogDump.ShowDialog(Me) = DialogResult.OK) AndAlso _ (Me.openFileDialogDump.FileName.Length > 0)) Then Me.myBot.isAcceptingUserInput = False Me.myBot.loadCustomTagHandlers(Me.openFileDialogDump.FileName) Me.myBot.isAcceptingUserInput = True AfficherMsg("La librairie personnalisée a été chargée avec succès !?") End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub toolStripMenuItemLoadSession_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles toolStripMenuItemLoadSession.Click Try Dim fi As New FileInfo(Application.ExecutablePath) Me.openFileDialogDump.InitialDirectory = fi.DirectoryName Me.openFileDialogDump.AddExtension = True Me.openFileDialogDump.DefaultExt = "xml" Me.openFileDialogDump.FileName = sNomFichierSessionUtilisateur If (Me.openFileDialogDump.ShowDialog(Me) = DialogResult.OK) Then ChargerSession(Me.openFileDialogDump.FileName) End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub toolStripMenuItemSaveSession_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles toolStripMenuItemSaveSession.Click Try Dim fi As New FileInfo(Application.ExecutablePath) Me.saveFileDialogDump.InitialDirectory = fi.DirectoryName Me.saveFileDialogDump.AddExtension = True Me.saveFileDialogDump.DefaultExt = "xml" Me.saveFileDialogDump.FileName = sNomFichierSessionUtilisateur If (Me.saveFileDialogDump.ShowDialog(Me) = DialogResult.OK) Then bSauverSession(Me.saveFileDialogDump.FileName) End If Catch ex As Exception AfficherMsg(ex.Message) End Try End Sub Private Sub ReinitialisationToolStripMenuItem_Click(ByVal sender As Object, _ ByVal e As EventArgs) Handles ReinitialisationToolStripMenuItem.Click bInitRobot() End Sub Private Sub aboutToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles aboutToolStripMenuItem.Click Dim about As String = _ "AIMLGui, Program# / AIMLBot (c) 2006 Nicholas H.Tollervey." & vbCrLf & _ "http://ntoll.org" & vbCrLf & vbCrLf & _ "This is a .NET implementation of the ALICE chatterbot using the AIML specification." & vbCrLf & _ "Put simply, this software will allow you to chat (by entering text)" & vbCrLf & _ "with your computer using natural language." & vbCrLf & vbCrLf & _ "Program# is a complete re-write of an earlier C# AIML implementation called AIMLBot." & vbCrLf & _ "It is available under the Gnu LGPL. This means that you are free to download," & vbCrLf & _ "modify and share it. Links to download Program# can be found at the bottom of the page." MessageBox.Show(about, "About", MessageBoxButtons.OK, MessageBoxIcon.Asterisk) End Sub Private Sub licenseToolStripMenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles licenseToolStripMenuItem.Click Dim content As String = vbCrLf & _ "Program# / AIMLBot - a .Net implementation of the AIML standard." & vbCrLf & _ "Copyright (C) 2006 Nicholas H.Tollervey (www.ntoll.org)" & vbCrLf & vbCrLf & _ "This library is free software; you can redistribute it and/or" & vbCrLf & _ "modify it under the terms of the GNU Lesser General Public" & vbCrLf & _ "License as published by the Free Software Foundation; either" & vbCrLf & _ "version 2.1 of the License, or (at your option) any later version." & vbCrLf & vbCrLf & _ "This library is distributed in the hope that it will be useful," & vbCrLf & _ "but WITHOUT ANY WARRANTY; without even the implied warranty of" & vbCrLf & _ "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" & vbCrLf & _ "Lesser General Public License for more details." & vbCrLf & vbCrLf & _ "You should have received a copy of the GNU Lesser General Public" & vbCrLf & _ "License along with this library; if not, write to the Free Software" & vbCrLf & _ "Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" MessageBox.Show(content, "License", MessageBoxButtons.OK, MessageBoxIcon.Asterisk) End Sub #End Region End Class modGlobal.vb ' Fichier modGlobal.vb ' -------------------- Module modGlobal #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 Const sNomAppli$ = "AliceVB" Public Const sTitreMsg$ = sNomAppli Public Const sNomDllSynthVoc$ = "Interop.SpeechLib.dll" ' Non compatible avec "Activer l'infrastructure de l'application" ' ne passe jamais ici, voir plutôt MyApplication_Startup 'Public Sub Main() ' ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE ' ' Sinon, ce n'est pas pratique de retrouver la ligne du bug : ' ' il faut cocher Thrown dans le menu Debug:Exception... pour les 2 lignes ' ' (dans ce cas, il peut y avoir beaucoup d'interruptions selon la logique ' ' de programmation : mieux vaut prévenir les erreurs que de les traiter) ' ' C'était plus simple avec On Error Goto X, car on pouvait ' ' désactiver la gestion d'erreur avec une simple constante bTrapErr. ' If bDebug Then Depart() : Exit Sub ' ' Attention : En mode Release il faut un Try Catch ici ' ' car sinon il n'y a pas de gestion d'erreur ! ' ' (.Net renvoie un message d'erreur équivalent ' ' à un plantage complet sans explication) ' Try ' Depart() ' Catch ex As Exception ' AfficherMsgErreur2(ex, "Main " & sTitreMsg) ' End Try 'End Sub 'Private Sub Depart() ' If bAppliDejaOuverte(bMemeExe:=True) Then Exit Sub ' Dim oFrm As New frmAliceVB ' ' ShowDialog ne fonctionne pas si aucune session n'est ouverte ' 'oFrm.ShowDialog() ' Application.Run(oFrm) 'End Sub End Module ApplicationEvents.vb ' Fichier ApplicationEvents.vb ' ---------------------------- Namespace My ' Les événements suivants sont disponibles pour MyApplication : ' ' Startup : déclenché au démarrage de l'application avant la création du formulaire de démarrage. ' Shutdown : déclenché après la fermeture de tous les formulaires de l'application. Cet événement n'est pas déclenché si l'application se termine de façon anormale. ' UnhandledException : déclenché si l'application rencontre une exception non gérée. ' StartupNextInstance : déclenché lors du lancement d'une application à instance unique et si cette application est déjà active. ' NetworkAvailabilityChanged : déclenché lorsque la connexion réseau est connectée ou déconnectée. Partial Friend Class MyApplication Private Sub MyApplication_Startup(ByVal sender As Object, _ ByVal e As Microsoft.VisualBasic.ApplicationServices.StartupEventArgs) _ Handles Me.Startup Dim sCheminDllAIMLBot$ = My.Application.Info.DirectoryPath & "\AIMLBot.dll" If Not bFichierExiste(sCheminDllAIMLBot, bPrompt:=True) Then e.Cancel = True End If End Sub End Class End Namespace ViewInformation.vb Imports System Imports System.ComponentModel Imports System.Drawing Imports System.Windows.Forms Public Class ViewInformation : Inherits Form ' Fields Private components As IContainer = Nothing Private richTextBoxInfo As RichTextBox ' Properties Public WriteOnly Property OutputMessage() As String Set(ByVal value As String) Me.richTextBoxInfo.Text = value End Set End Property ' Methods Public Sub New() Me.InitializeComponent() End Sub Public Sub New(ByVal sTitre$, ByVal pos As Point, ByVal taille As Size) Me.New() Me.Text = sTitre Me.InitialiserFrm(pos, taille) End Sub Protected Overrides Sub Dispose(ByVal disposing As Boolean) If (disposing AndAlso (Not Me.components Is Nothing)) Then Me.components.Dispose() End If MyBase.Dispose(disposing) End Sub Private Sub InitializeComponent() Me.richTextBoxInfo = New RichTextBox MyBase.SuspendLayout() Me.richTextBoxInfo.BackColor = SystemColors.ControlLightLight Me.richTextBoxInfo.Dock = DockStyle.Fill Me.richTextBoxInfo.Location = New Point(0, 0) Me.richTextBoxInfo.Name = "richTextBoxInfo" Me.richTextBoxInfo.ReadOnly = True Me.richTextBoxInfo.ScrollBars = RichTextBoxScrollBars.Vertical Me.richTextBoxInfo.Size = New Size(&H124, &H111) Me.richTextBoxInfo.TabIndex = 0 Me.richTextBoxInfo.Text = "" MyBase.AutoScaleDimensions = New SizeF(6.0!, 13.0!) MyBase.AutoScaleMode = Windows.Forms.AutoScaleMode.Font MyBase.ClientSize = New Size(&H124, &H111) MyBase.Controls.Add(Me.richTextBoxInfo) MyBase.Name = "ViewInformation" Me.Text = "ViewInformation" MyBase.ResumeLayout(False) End Sub Private Sub InitialiserFrm(ByVal pos As Point, ByVal taille As Size) ' Reprendre la taille et la position précédente de la fenêtre ' Positionnement de la fenêtre par le code : mode manuel Me.StartPosition = FormStartPosition.Manual ' Fixer la position et la taille de la feuille sauvées dans le fichier .exe.config Me.Location = pos Me.Size = taille End Sub End Class modMSAgent.vb ' Fichier modMSAgent.vb : Module de synthèse vocale via MS-Agent ' --------------------- #Const bLiaisonTardive = True '#Const bLiaisonTardive = False #If bLiaisonTardive Then Option Strict Off ' Liaison tardive #Else ' Liaison anticipée : ajouter les références vers ' Interop.AgentObjects.dll et AxInterop.AgentObjects.dll ' (voir le dossier \Dll_MSAgent pour aller plus vite) Option Strict On Imports AgentObjects ' Pour Agent et IAgentCtlCharacter #End If Module modMSAgent Private m_bVoixMSAgentPossible As Boolean Private m_bMSAgent As Boolean #If bLiaisonTardive Then Private m_oAgent As Object Private m_oMerlin As Object #Else 'Private WithEvents m_oAgent As Agent ' WithEvents pour recevoir l'év. _RequestComplete Private m_oAgent As Agent ' IAgentCtlCharacter 'Private m_oMerlinRequest As IAgentCtlRequest Private m_oMerlin As IAgentCtlCharacterEx 'IAgentCtlRequest #End If 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 sMSAgentInstEngTxt$ = "Lernout & Hauspie TruVoice American English TTS Engine (US : tv_enua.exe : 1 Mo)" Private Const sMSAgentInstEng$ = "tv_enua.exe" Private Const sMSAgentInstFrTxt$ = "Language component : French (AgtX040C.exe : 129 Ko)" Private Const sMSAgentInstFr$ = "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)" Public Function bInitMSAgent( _ Optional ByRef bVoixMSAgentPossible As Boolean = False, _ Optional ByVal bFrancais As Boolean = True) As Boolean ' Initialiser les MS-Agents et afficher le personnage Merlin Const sCleAgent$ = "Merlin" Const iCodeLangFR% = 1036 ' Français Const iCodeLangEng% = 1033 ' Anglais : &H809=2057=UK, &H409=1033=US Dim iCodeLang% = iCodeLangEng If bFrancais Then iCodeLang = iCodeLangFR Try m_oAgent = Nothing m_oMerlin = Nothing bVoixMSAgentPossible = False #If bLiaisonTardive Then If Not bCreerObjet(m_oAgent, sMSAgentCtrl2ProgID) Then Exit Function #Else m_oAgent = New Agent ' Liaison anticipée #End If m_oAgent.Connected = True ' Nécessaire en DotNet ! 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 ' Test du support de la langue choisie m_bVoixMSAgentPossible = True m_oAgent.Characters("Merlin").LanguageID = iCodeLang Dim sTest$ = m_oAgent.Characters("Merlin").TTSModeID If sTest.Length = 0 Then Dim sMsg$ = "La synthèse vocale en " If bFrancais Then sMsg &= "français (" & sMSAgentInstFr Else sMsg &= "anglais (" & sMSAgentInstFr End If sMsg &= ") n'est pas installée !" MsgBox(sMsg, MsgBoxStyle.Exclamation, sTitreMsg) m_bVoixMSAgentPossible = False End If m_oMerlin.Show() 'm_oMerlin.Speak("I can speak english") 'm_oMerlin.Speak("Je peux parler en français") ' Zoom 2 'm_oMerlin.Height *= 2 'm_oMerlin.Width *= 2 m_bMSAgent = True m_bVoixMSAgentPossible = m_oAgent.AudioOutput.Enabled ' Si TTS pas installé : false bVoixMSAgentPossible = m_bVoixMSAgentPossible bInitMSAgent = True Catch MsgBox("MS-Agent n'est pas installé !", _ MsgBoxStyle.Exclamation, sTitreMsg) End Try End Function Public Sub VerifierInstallMSAgent(ByRef bAgent As Boolean, ByRef bVoixActive As Boolean, _ Optional ByVal bFrancais As Boolean = True) ' Vérifier si les MS-Agents sont bien installés 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 = True If bFrancais Then bTTS_Ok = False 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 End If Dim bSAPI_Ok As Boolean = False 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 End Sub Public Function bVerifierEtInstallerMSAgent(Optional ByVal bFrancais As Boolean = True) As Boolean ' Vérifier si les MS-Agents sont bien installés, et les installer le cas échéant m_bMSAgent = False m_bVoixMSAgentPossible = False If Not bVerifierInstallObjet(sMSAgentCtrl2ProgID) Then If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInst1, sMSAgentInst1Txt, SMSAgentURL1) Then GoTo MsgReinst If bFrancais Then If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInstFr, sMSAgentInstFrTxt, SMSAgentURL) Then GoTo MsgReinst Else If Not bVerifierDllActiveX_InstExe(sMSAgentCtrl2, sMSAgentCtrl2ProgID, _ sMSAgentInstEng, sMSAgentInstEngTxt, SMSAgentURL) Then GoTo MsgReinst End If 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 bFrancais AndAlso 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 If Not bVerifierDllActiveX_InstExe(sSpeechAPI, "", _ sSpeechAPIInst, sSpeechAPIInstTxt, sSpeechAPI_URL, sCheminSAPI) Then _ GoTo MsgReinst m_bMSAgent = True m_bVoixMSAgentPossible = True bVerifierEtInstallerMSAgent = True Exit Function MsgReinst: MsgBox("Veuillez retester l'installation après l'installation du composant", _ MsgBoxStyle.Information, sTitreMsg) End Function Public Sub Dire(ByVal sTexte$, Optional ByVal bSilencieux As Boolean = False) If Not m_bMSAgent Then Exit Sub If sTexte.Length = 0 Then Exit Sub ' SpeakRequest permet de générer un évènement RequestComplete ' lorsque l'agent aura finit de parler #If bLiaisonTardive Then Dim SpeakRequest As Object ' LT #Else Dim SpeakRequest As IAgentCtlRequest ' LA #End If If m_bVoixMSAgentPossible And Not bSilencieux Then SpeakRequest = m_oMerlin.Speak(sTexte) Else ' Mode silencieux 'sTexte = "\vol=0\" & sTexte Ne marche pas ! 'SpeakRequest = m_oMerlin.Think(sTexte) ' Ok mais change l'aspect ' Selon Remy Lebeau dans microsoft.public.msagent 'Use the \map\ speech tag to fill in an empty audio string: sTexte = "\map=""""=""" & sTexte & """\" SpeakRequest = m_oMerlin.Speak(sTexte) End If ' Attendre la fin de la prononciation du message pour afficher le message ' 1ère solution : Il faut pouvoir récupérer l'événement ' m_oAgent_RequestComplete (voir ci-dessous) 'm_oMerlin.Wait(MerlinRequest) ' Autre solution : + simple Dim iStatut% = 0 ' 2 = pending, 4 = in progress Do iStatut = SpeakRequest.Status Application.DoEvents() Loop While iStatut = 2 Or iStatut = 4 End Sub 'Private Sub m_oAgent_RequestComplete(ByVal 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 Public Sub AfficherMSAgent() If Not m_bMSAgent Then Exit Sub m_oMerlin.Show() End Sub Public Sub CacherMSAgent() If Not m_bMSAgent Then Exit Sub m_oMerlin.Hide() End Sub End Module modSynthVocale.vb ' Fichier modSynthVocale.vb : Module de synthèse vocale via SpVoiceClass ' ------------------------- ' L'avantage de déplacer cet import dans un module est que le code ne plante pas ' si la dll n'est pas trouvée au moment précis de son utilisation Imports SpeechLib Module modSynthVocale Public Sub Dire2(ByVal sTexte$) Dim objSpeech As SpVoice = New SpVoiceClass objSpeech.Speak(sTexte, SpeechVoiceSpeakFlags.SVSFlagsAsync) objSpeech.SynchronousSpeakTimeout = 20 objSpeech.Rate = 4 End Sub End Module modUtilitaire.vb ' Fichier modUtilitaire.vb ' ------------------------ Imports Microsoft.Win32 ' Pour RegistryKey Module Utilitaire #Region "Divers" Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal 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 CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' 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) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub Public Function bVerifierDllActiveX_InstExe(ByVal sTitreComposant$, _ ByVal sClasseDllActiveX$, ByVal sExeInstall$, ByVal sTypeComposant$, _ ByVal sURLInst$, _ Optional ByVal sCheminFichierDoitExister$ = "", _ Optional ByVal sDossierInst$ = "\Installation", _ Optional ByVal 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() : Exit Function OuvrirAppliAssociee(sURLInst, bVerifierFichier:=False) Exit Function End If If MsgBoxResult.Cancel = MsgBox(sMsg1 & vbLf & _ "Cliquez sur Ok pour installer ce composant :" & vbLf & _ sTypeComposant, _ vbOKCancel Or vbCritical, sTitreMsg) Then Exit Function OuvrirAppliAssociee(sCheminExeInstall) ' Poursuivre les autres installations bVerifierDllActiveX_InstExe = True End Function Public Function bCleRegistreCRExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCle As RegistryKey = Registry.ClassesRoot Using rkSousCle As RegistryKey = rkCle.OpenSubKey(sCle & "\\" & sSousCle) If IsNothing(rkSousCle) Then Exit Function bCleRegistreCRExiste = True End Using End Using Catch End Try End Function #End Region End Module modUtilLT.vb ' Fichier modUtilLT.vb : Module de fonctions utilitaires en liaison tardive ' -------------------- Option Strict Off ' Pour oObjetQcq.Version Module modUtilLT Public Function bVerifierInstallObjet(ByVal sClasse$, _ Optional ByRef sVersion$ = "", _ Optional ByVal bClassID As Boolean = False, _ Optional ByVal 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 bVerifierInstallObjet = True End If Exit Function 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, ByVal sClasse$) As Boolean ' Instancier un contrôle ActiveX en liaison tardive (à l'exécution) ' Attention, avec Outlook, le CreateObject fait plutôt un GetObject ' (comme toutes les applications qui sont à instance unique : ' si l'appli était déjà ouverte, elle disparait, voir bCreerObjet2) Try oObjetQcq = CreateObject(sClasse) bCreerObjet = True Catch Err As Exception AfficherMsgErreur2(Err, "bCreerObjet", _ "L'objet de classe [" & sClasse & "] ne peut pas être créé") oObjetQcq = Nothing End Try End Function 'Public Function bCreerObjet2(ByRef oObjetQcq As Object, ByVal sClasse$, _ ' Optional ByRef bObjDejaOuvert As Boolean = False) As Boolean ' On Error Resume Next ' oObjetQcq = GetObject(, sClasse) ' If Err.Number <> 0 Then ' bObjDejaOuvert = False ' Err.Clear() ' oObjetQcq = CreateObject(sClasse) ' Else ' bObjDejaOuvert = True ' End If ' If Err.Number <> 0 Then ' AfficherMsgErreur(Err, "bCreerObjet2", _ ' "L'objet de classe [" & sClasse & "] ne peut pas être créé", _ ' "Cause possible : " & sClasse & " n'est pas installé") ' Err.Clear() : oObjetQcq = Nothing : GoTo Fin ' End If ' bCreerObjet2 = True 'Fin: ' On Error GoTo 0 'End Function End Module modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... Module modUtilFichier Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Const sCauseErrPossDossier$ = _ "Le dossier est peut-être protégé en écriture" & vbLf & _ "ou bien un fichier est verrouillé par une autre application" #Region "Gestion des fichiers" Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "", _ Optional ByVal bDoitExister As Boolean = True) As Boolean ' Afficher une boite de dialogue pour choisir un fichier ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*" ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier Static bInit As Boolean = False Dim ofd As New OpenFileDialog With ofd If Not bInit Then bInit = True If sInitDir.Length = 0 Then If sCheminFichier.Length = 0 Then .InitialDirectory = Application.StartupPath Else .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) End If Else .InitialDirectory = sInitDir End If End If If Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier .CheckFileExists = bDoitExister ' 14/10/2007 .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = False .Title = sTitre .ShowDialog() If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName End With End Function Public Function bFichierExiste(ByVal sCheminFichier$, _ Optional ByVal 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 bFichierExisteFiltre(ByVal sCheminFiltre$, ByVal sFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim di As New IO.DirectoryInfo(sCheminFiltre) Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre = (iNbFichiers > 0) If Not bFichierExisteFiltre And bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichiers introuvables") End Function Public Function bFichierExisteFiltre2(ByVal sCheminFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If sCheminFiltre.Length = 0 Then Exit Function 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) bFichierExisteFiltre2 = bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(ByVal sCheminDossier$, ByVal sFiltre$) ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt Dim di As New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then Exit Function Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo iNbFichiersFiltres = fi.GetLength(0) End Function Public Function bCopierFichier(ByVal sCheminSrc$, ByVal sCheminDest$, _ Optional ByVal bPromptErr As Boolean = True, _ Optional ByVal bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Exit Function Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) Dim lTailleSrc& = New IO.FileInfo(sCheminSrc).Length If bFichierExiste(sCheminDest) Then Dim dDateDest As Date = IO.File.GetLastWriteTime(sCheminDest) Dim lTailleDest& = New IO.FileInfo(sCheminDest).Length ' Si la date et la taille sont les mêmes, la copie est déjà faite ' (la vérification du hashcode serait plus sûr mais trop longue ' de toute façon : il serait alors plus rapide de tjrs recopier) If dDateSrc = dDateDest And lTailleSrc = lTailleDest Then _ bCopierFichier = True : Exit Function ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Exit Function End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Exit Function 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Exit Function 'End If Try IO.File.Copy(sCheminSrc, sCheminDest) bCopierFichier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bCopierFichier", _ "Impossible de copier le fichier source :" & vbLf & _ sCheminSrc & vbLf & "vers le fichier de destination :" & _ vbLf & sCheminDest, sCauseErrPoss) End Try End Function Public Function bSupprimerFichier(ByVal sCheminFichier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then _ bSupprimerFichier = True : Exit Function If Not bFichierAccessible(sCheminFichier, _ bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then _ Exit Function ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) bSupprimerFichier = True Catch ex As Exception If bPromptErr Then _ MsgBox("Impossible de supprimer le fichier :" & vbLf & _ sCheminFichier & vbLf & _ sCauseErrPoss, MsgBoxStyle.Critical, sTitreMsg) End Try End Function Public Function bSupprimerFichiersFiltres(ByVal sCheminDossier$, ByVal sFiltre$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt ' Si le dossier n'existe pas, on considère que c'est un succès If Not bDossierExiste(sCheminDossier) Then bSupprimerFichiersFiltres = True : Exit Function Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Exit Function Next sFichier bSupprimerFichiersFiltres = True End Function Public Function bRenommerFichier(ByVal sSrc$, ByVal sDest$, _ Optional ByVal bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Exit Function If bConserverDest Then ' Cette option permet de conserver le fichier de destination s'il existe If bFichierExiste(sDest) Then ' Dans ce cas on supprime la source If Not bSupprimerFichier(sSrc) Then Exit Function bRenommerFichier = True Exit Function End If Else If Not bSupprimerFichier(sDest) Then Exit Function End If Try IO.File.Move(sSrc, sDest) bRenommerFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerFichier", _ "Impossible de renommer le fichier source :" & vbLf & _ sSrc & vbLf & "vers le fichier de destination :" & vbLf & sDest, _ sCauseErrPoss) End Try End Function Public Function bDeplacerFichiers2(ByVal sSrc$, ByVal sDest$) As Boolean ' Renommer ou déplacer une arborescence de fichiers ' Attention : cette fonction nécessite la suppression du dossier src ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3 ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\ ' Cette fonction est déjà dans : modUtilFichierLT.vb Dim bStatut As Boolean, sListeErr$ = "" If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Exit Function Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Exit Function bDeplacerFichiers2 = True End Function Public Function bDeplacerFichiers3(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _ Optional ByVal bConserverDest As Boolean = True, _ Optional ByVal sExtDest$ = "", Optional ByVal sPrefixe$ = "") As Boolean ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination ' en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination ' (option par défaut pour conserver la date) If Not bVerifierCreerDossier(sCheminDest) Then Exit Function Dim bChExt As Boolean = False If sExtDest.Length > 0 Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = fi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(fi(i).Name) Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier ' Option possible : changer l'extension du fichier ' par exemple rename *.csv *.txt If bChExt Then sDest = sCheminDest & "\" & sPrefixe & _ IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Exit Function Next i bDeplacerFichiers3 = True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False, _ Optional ByVal bPromptFermer As Boolean = False, _ Optional ByVal bInexistOk As Boolean = False, _ Optional ByVal bPromptRetenter As Boolean = False) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, même une simple ouverture n'est pas permise Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _ sCheminFichier & vbLf & _ "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _ "ses attributs de protection, ou alors les droits d'accès." & _ sQuestion, msgbs, sTitreMsg) 'reponse = MsgBox("Veuillez fermer le fichier :" & vbLf & _ ' sCheminFichier & vbLf & _ ' "(le fichier n'est pas accessible en écriture)" & sQuestion, _ ' msgbs, sTitreMsg) End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub ProposerOuvrirFichier(ByVal sCheminFichier$, _ Optional ByVal sInfo$ = "") If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sMsg$ = _ "Le fichier " & IO.Path.GetFileName(sCheminFichier) & _ " a été créé avec succès :" & vbLf & _ sCheminFichier If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _ Optional ByVal bMax As Boolean = False, _ Optional ByVal 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 sFormaterTailleOctets$(ByVal lTailleOctets&, _ Optional ByVal bDetail As Boolean = False) ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll ' 1024 est la norme actuellement employée dans Windows, ' mais 1000 sera peut être un jour la norme ' http://fr.wikipedia.org/wiki/Octet Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1)) Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1)) Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1)) Dim sAffichage$ = "" If bDetail Then sAffichage = sFormaterNumerique(lTailleOctets) & " octets" If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko" If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo" If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go" If rNbKo >= 1 Or rNbMo >= 1 Or rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0:=False) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0:=False) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0:=False) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, _ bSupprimerPt0:=True) & " octets" End If End If sFormaterTailleOctets = sAffichage End Function Public Function sFormaterNumerique$(ByVal rVal!, _ Optional ByVal bSupprimerPt0 As Boolean = True) ' Formater un numérique avec une précision d'une décimale ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 Dim nfi As Globalization.NumberFormatInfo = _ New Globalization.NumberFormatInfo ' Définition des spérateurs numériques nfi.NumberGroupSeparator = " " ' Séparateur des milliers, millions... nfi.NumberDecimalSeparator = "." ' Séparateur décimal ' 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = 1 ' 1 décimale de précision If bSupprimerPt0 Then nfi.NumberDecimalDigits = 0 sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 'If bSupprimerPt0 Then _ ' sFormaterNumerique = sFormaterNumerique.Replace(".0", "") End Function Public Function sFormaterNumerique2$(ByVal rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(ByVal sCheminDossier$) As Boolean ' Vérifier si le dossier existe, et le créer sinon Dim di As New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function di.Create() di = New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function MsgBox("Impossible de créer le dossier :" & vbCrLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg) End Function Public Function bDossierExiste(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() bDossierExiste = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste And bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg & " - Dossier introuvable") End Function Public Function bRenommerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Exit Function Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bRenommerDossier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerDossier", _ "Impossible de renommer le dossier source :" & vbLf & _ sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bDeplacerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$, _ Optional ByVal bPromptErr As Boolean = True) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bRenommerDossier ' Roir aussi My.Computer.MoveDirectory en DotNet2 If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Exit Function Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bDeplacerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bDeplacerDossier", _ "Impossible de déplacer le dossier source :" & vbLf & sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bSupprimerDossier(ByVal sCheminDossier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then _ bSupprimerDossier = True : Exit Function Try IO.Directory.Delete(sCheminDossier, recursive:=True) ' Si l'explorateur est ouvert sur le dossier, il faut attendre qq sec. ' pour que le dossier soit bien détruit Dim i% = 0 While bDossierExiste(sCheminDossier) And i < 10 TraiterMsgSysteme_DoEvents() Threading.Thread.Sleep(1000) i += 1 End While If i = 10 Then If bPromptErr Then _ MsgBox("Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bSupprimerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) End Try End Function Public Function sDossierParent$(ByVal sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp ' (à renommer plutot en sCheminDossierParent ?) ' Ex. avec un chemin de fichier ' C:\Tmp\MonFichier.txt -> C:\Tmp ' Ex. avec un chemin de fichier avec filtre ' C:\Tmp\*.txt -> C:\Tmp sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Function sNomDossierFinal$(ByVal sCheminDossier$) ' Renvoyer le nom du dernier dossier à partir du chemin du dossier ' Exemples : ' C:\Tmp\Tmp\MonDossier -> MonDossier ' C:\MonDossier\ -> MonDossier ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé) sNomDossierFinal = sCheminDossier sCheminDossier = sEnleverSlashFinal(sCheminDossier) Dim iPosDossier% = sCheminDossier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1) End Function Public Function sExtraireChemin$(ByVal sCheminFichier$, _ Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", _ Optional ByRef sNomFichierSansExt$ = "") ' Retourner le chemin du fichier passé en argument ' Non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension ' Exemple : ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier) sNomFichier = IO.Path.GetFileName(sCheminFichier) sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier) sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt) End Function Public Function sNomDossierParent$(ByVal sCheminDossierOuFichier$, _ Optional ByVal sCheminReference$ = "") ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier ' sauf si le dossier parent n'existe pas : chemin de référence ' Exemples avec un dossier : ' C:\Tmp\Tmp\MonDossier -> \Tmp\MonDossier ' C:\MonDossier -> \MonDossier ' Exemples avec un fichier : ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt sNomDossierParent = "" Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier) ' Si c'est le chemin de référence, on le renvoit tel quel Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier) If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function Dim iFin% = iPosDossier - 1 Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin) If iPosDossierParent < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent) End Function Public Function sCheminRelatif$(ByVal sCheminFichier$, ByVal sCheminReference$) ' Renvoyer le chemin relatif au chemin de référence ' à partir du chemin complet du fichier ' Exemples avec C:\ pour le chemin de référence ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt ' Exemple avec C:\Tmp1 pour le chemin de référence ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(ByVal sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashFinal = "" : Exit Function If sChemin.EndsWith("\") Then sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1) Else sEnleverSlashFinal = sChemin End If End Function Public Function sEnleverSlashInitial$(ByVal sChemin$) ' Enlever le slash au début du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashInitial = "" : Exit Function If sChemin.StartsWith("\") Then sEnleverSlashInitial = sChemin.Substring(1) Else sEnleverSlashInitial = sChemin End If End Function Public Function bCopierArbo(ByVal sSrc$, ByVal sDest$, _ ByRef bStatut As Boolean, _ ByRef sListeErr$, Optional ByVal sListeErrExcep$ = "") As Boolean ' Copier une arborescence de fichiers ' en retournant bStatut : Succès ou Echec de la fonction récursive ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est ' indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers ' de ce rapport si on sait déjà qu'on ne pourra les copier) If sDest.Chars(sDest.Length - 1) <> IO.Path.DirectorySeparatorChar Then _ sDest &= IO.Path.DirectorySeparatorChar Try If Not IO.Directory.Exists(sDest) Then IO.Directory.CreateDirectory(sDest) Catch ex As Exception AfficherMsgErreur2(ex, "bCopierArbo", _ "Impossible de créer le dossier :" & vbLf & _ sDest, sCauseErrPossDossier) Exit Function End Try Dim aElements$() = IO.Directory.GetFileSystemEntries(sSrc) For Each sCheminElements As String In aElements Dim sNomElements$ = IO.Path.GetFileName(sCheminElements) If IO.Directory.Exists(sCheminElements) Then ' L'élement est un sous-dossier : le copier bCopierArbo(sCheminElements, sDest & sNomElements, bStatut, _ sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(sCheminElements, sDest & sNomElements, True) Catch ex As Exception If sListeErrExcep.IndexOf(" " & sNomElements & " ") = -1 Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next bCopierArbo = bStatut End Function Public Function sLecteurDossier$(ByVal sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 ' Mettre & pour Long en DotNet1 et % pour Integer en DotNet2 Public Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern Public Function sLireFichier$(ByVal sCheminFichier$) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim fs As IO.FileStream = Nothing Dim sr As IO.StreamReader = Nothing Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Try fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv sr = New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbContenu.Append(vbCrLf) bDebut = True sbContenu.Append(sLigne) Loop While True Catch Ex As Exception AfficherMsgErreur2(Ex, "sLireFichier") Exit Function Finally If Not (sr Is Nothing) Then sr.Close() If Not (fs Is Nothing) Then fs.Close() End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(ByVal sCheminFichier$) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim fs As IO.FileStream = Nothing Dim sr As IO.StreamReader = Nothing Dim bDebut As Boolean = False Try fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv sr = New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbLireFichier.Append(vbCrLf) bDebut = True sbLireFichier.Append(sLigne) Loop While True Catch Ex As Exception AfficherMsgErreur2(Ex, "sbLireFichier") Exit Function Finally If Not (sr Is Nothing) Then sr.Close() If Not (fs Is Nothing) Then fs.Close() End Try End Function Public Function asLireFichier(ByVal sCheminFichier$) As String() ' Lire et renvoyer le contenu d'un fichier asLireFichier = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function asLireFichier = IO.File.ReadAllLines(sCheminFichier, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) End Function Public Function bEcrireFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) sw.Close() bEcrireFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bEcrireFichier", _ "Impossible d'écrire les données dans le fichier :" & _ vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False) As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø sw = New IO.StreamWriter(sCheminFichier, append:=False) ElseIf bEncodageISO_8859_1 Then sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding("ISO-8859-1")) Else ' Encodage par défaut de VB6 et de Windows en français sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) End If sw.Write(sContenu) sw.Close() bEcrireFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bEcrireFichier", _ "Impossible d'écrire les données dans le fichier :" & _ vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) sw.Close() bAjouterFichier = True Catch Ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & Ex.Message If bPrompt Then AfficherMsgErreur2(Ex, "bAjouterFichier", sMsg) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) sw.Close() bAjouterFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(ByVal sCheminFichier$) As Boolean ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Exit Function bReencoder = bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" Public Function asArgLigneCmd(ByVal sFichiers$) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim iNbArg%, sFichier$, sSepar$ Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean sCmd = sFichiers 'Command$ iLen = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Si le premier caractère est un guillement, c'est un nom long If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong Then iDeb2 += 1 ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2 iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLen + 1 sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2)) If sFichier <> "" Then ReDim Preserve asArgs(iNbArg) asArgs(iNbArg) = sFichier iNbArg += 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop Const iCodeGuillemets% = 34 Dim iNumArg% For iNumArg = 0 To UBound(asArgs) asArgs(iNumArg) = Trim$(asArgs(iNumArg)) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" End If Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(ByVal sChaine$, _ Optional ByVal bLimit8Car As Boolean = False, _ Optional ByVal bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 correcte si demandé Dim iSel%, sBuffer$, sCar$, iCode%, sCarConv2$, sCarDest$ Dim bOk As Boolean, bMaj As Boolean sBuffer = Trim$(sChaine) If bLimit8Car Then sBuffer = Left$(sBuffer, 8) Const sCarConv$ = " .«»/[]:;|=,*-" ' Caractères à convertir en souligné sCarConv2 = sCarConv If Not bConserverSignePlus Then sCarConv2 &= "+" For iSel = 1 To Len(sBuffer) sCar = Mid$(sBuffer, iSel, 1) iCode = Asc(sCar) bMaj = False If iCode >= 65 And iCode <= 90 Then bMaj = True If iCode >= 192 And iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If bConserverSignePlus And iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 And iCode <= 90) Then bOk = True If (iCode >= 97 And iCode <= 122) Then bOk = True If (iCode >= 48 And iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function #End Region End Module