Logotron v1.0.7.*Table des procédures 1 - AssemblyInfo.vb 2 - frmLogotron.vb 2.1 - Private Sub Activation 2.2 - Private Sub AfficherMessage 2.3 - Private Sub AfficherTexte 2.4 - Private Sub chkOrigineGrecoLatin_Click 2.5 - Private Sub chkOrigineNeoRigolo_Click 2.6 - Private Sub cmdAnnuler_Click 2.7 - Private Sub cmdAvert_Click 2.8 - Private Sub cmdCopier_Click 2.9 - Private Sub cmdGo_Click 2.10 - Private Sub cmdQuiz_Click 2.11 - Private Sub EffacerMessages 2.12 - Private Sub Form1_Load 2.13 - Private Sub Initialisation 2.14 - Private Sub lbFreq_SelectedValueChanged 2.15 - Private Sub lbNbPrefixes_SelectedValueChanged 2.16 - Private Sub lbNiveau_SelectedValueChanged 2.17 - Private Sub MajNbMotsLogotron 2.18 - Private Sub Sablier 3 - frmQuiz.vb 3.1 - Private Sub Activation 3.2 - Private Sub AfficherMsgBarreMsg 3.3 - Private Sub AfficherTexte 3.4 - Private Sub chkMotsExistants_Click 3.5 - Private Sub chkOrigineGrecoLatin_Click 3.6 - Private Sub chkOrigineNeoRigolo_Click 3.7 - Private Sub cmdCopier_Click 3.8 - Private Sub cmdQuiz_Click 3.9 - Private Sub cmdValider_Click 3.10 - Private Sub EffacerMessages 3.11 - Private Sub frmQuiz_FormClosing 3.12 - Private Sub frmQuiz_Load 3.13 - Private Sub lbFreq_SelectedValueChanged 3.14 - Private Sub lbNiveau_SelectedValueChanged 3.15 - Private Sub lbPrefixesPossibles_Click 3.16 - Private Sub lbResultats_Click 3.17 - Private Sub lbSuffixesPossibles_Click 3.18 - Private Sub MajNbMotsQuiz 3.19 - Private Sub QuizDefinition 3.20 - Private Sub QuizDefinitionMotExistant 3.21 - Private Sub QuizSegment 3.22 - Private Sub QuizSegmentMotExistant 4 - _modConst.vb 5 - modConstLogotron.vb 6 - modEnum.vb 6.1 - Public Shared Function iCoef% 6.2 - Public Shared Function iCoef% 6.3 - Public Shared Function sConv$ 7 - clsBase.vb 7.1 - Private Function sRemplacerCar$ 7.2 - Private Function sSupprimerArticleInterm$ 7.3 - Public Function bLireMot 7.4 - Public Function bLireSegment 7.5 - Public Function bTrouverSegment 7.6 - Public Function bTrouverSegment 7.7 - Public Function iLireNbSegments% 7.8 - Public Function iLireNbSegmentsUniques% 7.9 - Public Function iNbMotsExistants% 7.10 - Public Function iNbMotsExistantsTotal% 7.11 - Public Function iNbPrefixesMotsExistants% 7.12 - Public Function iNbSuffixesMotsExistants% 7.13 - Public Function iTirageMotExistant% 7.14 - Public Function iTirageMotExistantAutre% 7.15 - Public Function iTirageSegment% 7.16 - Public Function iTirageSegment% 7.17 - Public Function lstMotsExistants 7.18 - Public Function lstPrefixesMotsExistants 7.19 - Public Function lstSegmentsAutreOrigine 7.20 - Public Function lstSuffixesMotsExistants 7.21 - Public Function ObtenirSegmentBases 7.22 - Public Function ObtenirSegments 7.23 - Public Function sAfficher$ 7.24 - Public Function sAfficherPrefixe$ 7.25 - Public Function sAfficherSuffixe$ 7.26 - Public Function sCompleterPrefixe$ 7.27 - Public Function sSupprimerArticle$ 7.28 - Public Function sTrouverEtymologie$ 7.29 - Public Overrides Function ToString$ 7.30 - Public Shared Sub ParserDefinition 7.31 - Public Sub AjouterSegment 7.32 - Public Sub ChargerMotsExistantsCsv 7.33 - Public Sub DefinirSegments 7.34 - Public Sub InitBases 7.35 - Public Sub New 7.36 - Public Sub New 7.37 - Public Sub New 7.38 - Public Sub New 7.39 - Public Sub New 7.40 - Public Sub ParserDefinition 7.41 - Public Sub Synthese 8 - clsDefExclusives.vb 8.1 - Public Function bSensExclusifAutre 8.2 - Public Sub AjouterListe 8.3 - Public Sub New 9 - modListeMotsExistants.vb 9.1 - Public Sub ChargerMotsExistantsCode 10 - modListePrefixes.vb 10.1 - Public Sub InitialisationPrefixes 11 - modListeSuffixes.vb 11.1 - Public Sub InitialisationSuffixes 12 - modLogotron.vb 12.1 - Private Function bLireSensConcept 12.2 - Private Sub CreerListeRacines 12.3 - Private Sub CreerListeSegments 12.4 - Private Sub DecompteRacine 12.5 - Private Sub DecompteSegment 12.6 - Private Sub TraiterJSon 12.7 - Public Function bTirage 12.8 - Public Sub LireLogotronCsv 12.9 - Public Sub LireLogotronJSon 12.10 - Public Sub TraiterEtExporterDonnees 13 - modUtil.vb 13.1 - Public Function bCopierPressePapier 13.2 - Public Function iFix% 13.3 - Public Function iRandomiser% 13.4 - Public Function rRandomiser! 13.5 - Public Function sLireListBox$ 13.6 - Public Sub AfficherMsgErreur 13.7 - Public Sub AfficherMsgErreur2 13.8 - Public Sub AfficherTexteListBox 13.9 - Public Sub RemplirListBoxAuHasard 13.10 - Public Sub TraiterMsgSysteme_DoEvents 13.11 - Public Sub VBMessageBox 14 - clsAfficherMsg.vb 14.1 - Public ReadOnly Property bDesactiver 14.2 - Public ReadOnly Property fsi 14.3 - Public ReadOnly Property iNumFichierEnCours% 14.4 - Public ReadOnly Property lAvancement 14.5 - Public ReadOnly Property sMessage$ 14.6 - Public ReadOnly Property sMessage$ 14.7 - Public Sub AfficherAvancement 14.8 - Public Sub AfficherFichierEnCours 14.9 - Public Sub AfficherFSIEnCours 14.10 - Public Sub AfficherMsg 14.11 - Public Sub New 14.12 - Public Sub New 14.13 - Public Sub New 14.14 - Public Sub New 14.15 - Public Sub New 14.16 - Public Sub New 14.17 - Public Sub New 14.18 - Public Sub New 14.19 - Public Sub New 14.20 - Public Sub Sablier 14.21 - Public Sub Tick 15 - clsDicoTri.vb 15.1 - Protected Sub New 15.2 - Public Function Trier 15.3 - Sub New 16 - modUtilFichier.vb 16.1 - Private Function sbRemoveDiacritics 16.2 - Private Function sRemoveDiacritics$ 16.3 - Public Function asArgLigneCmd 16.4 - Public Function asLignes 16.5 - Public Function asLireFichier 16.6 - Public Function bAjouterFichier 16.7 - Public Function bAjouterFichier 16.8 - Public Function bCopierArbo 16.9 - Public Function bCopierFichier 16.10 - Public Function bCopierFichiers 16.11 - Public Function bDeplacerDossier 16.12 - Public Function bDeplacerFichiers2 16.13 - Public Function bDeplacerFichiers3 16.14 - Public Function bDossierExiste 16.15 - Public Function bEcrireFichier 16.16 - Public Function bEcrireFichier 16.17 - Public Function bFichierExiste 16.18 - Public Function bFichierExisteFiltre 16.19 - Public Function bFichierExisteFiltre2 16.20 - Public Function bListToHashSet 16.21 - Public Function bReencoder 16.22 - Public Function bRenommerDossier 16.23 - Public Function bRenommerFichier 16.24 - Public Function bSupprimerDossier 16.25 - Public Function bSupprimerFichier 16.26 - Public Function bSupprimerFichiersFiltres 16.27 - Public Function bTrouverFichier 16.28 - Public Function bVerifierCreerDossier 16.29 - Public Function iNbFichiersFiltres% 16.30 - Public Function LireEncodage 16.31 - Public Function sbEnleverAccents 16.32 - Public Function sbLireFichier 16.33 - Public Function sCheminRelatif$ 16.34 - Public Function sConvNomDos$ 16.35 - Public Function sDossierParent$ 16.36 - Public Function sEnleverAccents$ 16.37 - Public Function sEnleverSlashFinal$ 16.38 - Public Function sEnleverSlashInitial$ 16.39 - Public Function sExtraireChemin$ 16.40 - Public Function sFormaterNumerique$ 16.41 - Public Function sFormaterNumerique2$ 16.42 - Public Function sFormaterNumeriqueLong$ 16.43 - Public Function sFormaterTailleKOctets$ 16.44 - Public Function sFormaterTailleOctets$ 16.45 - Public Function sLecteurDossier$ 16.46 - Public Function sLireFichier$ 16.47 - Public Function sNomDossierFinal$ 16.48 - Public Function sNomDossierParent$ 16.49 - Public Function StringReadLine$ 16.50 - Public FunctionbFichierAccessible 16.51 - Public Sub New 16.52 - Public SubOuvrirAppliAssociee 16.53 - Public SubOuvrirDossier 16.54 - Public SubProposerOuvrirFichier 17 - UniversalComparer.vb 17.1 - Public Function Compare 17.2 - Public Function Compare 17.3 - Public Sub New 18 - GlobalSuppressions.vb AssemblyInfo.vb Imports System.Reflection <Assembly: AssemblyTitle("Logotron")> <Assembly: AssemblyDescription("Logotron, d'après l'idée de Jean-Pierre Petit")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("Logotron")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2020")> <Assembly: AssemblyTrademark("")> <Assembly: AssemblyVersion("1.0.7.*")> <Assembly: Runtime.InteropServices.ComVisible(False)> ' CA1017 <Assembly: CLSCompliant(True)> ' CA1014 <Assembly: Resources.NeutralResourcesLanguage("")> ' CA1824 frmLogotron.vb ' Logotron : jouer avec les préfixes et les suffixes de la langue française ' ------------------------------------------------------------------------- ' https://github.com/PatriceDargenton/Logotron ' Documentation : Logotron.html ' http://patrice.dargenton.free.fr/CodesSources/Logotron/index.html ' http://patrice.dargenton.free.fr/CodesSources/Logotron/Logotron.vbproj.html ' Version 1.04 du 05/05/2018 : Gestion des élisions (ex.: palé(o) - onto - logie) ' Version 1.01 du 02/09/2018 : Première version ' Par Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' ------------------------------------------------------------------------- ' D'après la source : ' https://www.jp-petit.org/Divers/LOGOTRON/logotron.HTM ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ Imports System.Text Public Class frmLogotron Private m_bMajViaCode As Boolean = False Private WithEvents m_msgDelegue As clsMsgDelegue = New clsMsgDelegue Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load Dim sVersion$ = " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sDebug$ = " - Debug" Dim sTxt$ = Me.Text & sVersion If bDebug Then sTxt &= sDebug Me.Text = sTxt Initialisation(bAfficherAvert:=False) m_bMajViaCode = True Me.lbNiveau.SetSelected(0, True) Me.lbNiveau.SetSelected(1, True) Me.lbNiveau.SetSelected(2, True) Me.lbNbPrefixes.Text = sHasard Me.lbFreq.SetSelected(0, True) Me.lbFreq.SetSelected(1, True) Me.lbFreq.SetSelected(2, True) Me.lbFreq.SetSelected(3, True) m_bMajViaCode = False MajNbMotsLogotron() End Sub Private Sub Initialisation(bAfficherAvert As Boolean) EffacerMessages() InitBases() If sModeLectureMotsExistants = enumModeLectureMotExistant.sCsv Then ChargerMotsExistantsCsv() ElseIf sModeLectureMotsExistants = enumModeLectureMotExistant.sCode Then ChargerMotsExistantsCode(m_dicoMotsExistants) End If Dim sCheminLogotronCsv$ = Application.StartupPath & "\Logotron" & sLang & ".csv" Dim sCheminSensConcept$ = Application.StartupPath & "\SensConcept" & sLang & ".csv" InitialisationPrefixes(sCheminLogotronCsv, sModeLecture, m_msgDelegue) InitialisationSuffixes(sModeLecture) TraiterEtExporterDonnees(bAfficherAvert, m_msgDelegue, sCheminSensConcept) End Sub Private Sub cmdAvert_Click(sender As Object, e As EventArgs) Handles cmdAvert.Click Initialisation(bAfficherAvert:=True) End Sub Private Sub cmdAnnuler_Click(sender As Object, e As EventArgs) Handles cmdAnnuler.Click m_msgDelegue.m_bAnnuler = True End Sub Private Sub AfficherMessage(sender As Object, e As clsMsgEventArgs) _ Handles m_msgDelegue.EvAfficherMessage AfficherTexte(e.sMessage) End Sub Private m_iIndex% = 0 Private Sub AfficherTexte(sTxt$) AfficherTexteListBox(sTxt, m_iIndex, Me, Me.lbResultats) End Sub Private Sub EffacerMessages() lbResultats.Items.Clear() m_iIndex = 0 End Sub Private Sub lbNiveau_SelectedValueChanged(sender As Object, e As EventArgs) _ Handles lbNiveau.SelectedValueChanged If m_bMajViaCode Then Exit Sub MajNbMotsLogotron() End Sub Private Sub lbFreq_SelectedValueChanged(sender As Object, e As EventArgs) _ Handles lbFreq.SelectedValueChanged If m_bMajViaCode Then Exit Sub MajNbMotsLogotron() End Sub Private Sub lbNbPrefixes_SelectedValueChanged(sender As Object, e As EventArgs) _ Handles lbNbPrefixes.SelectedValueChanged If m_bMajViaCode Then Exit Sub MajNbMotsLogotron() End Sub Private Sub chkOrigineGrecoLatin_Click(sender As Object, e As EventArgs) _ Handles chkOrigineGrecoLatin.Click If m_bMajViaCode Then Exit Sub If Me.chkOrigineGrecoLatin.Checked Then Me.chkOrigineNeoRigolo.Checked = False MajNbMotsLogotron() End Sub Private Sub chkOrigineNeoRigolo_Click(sender As Object, e As EventArgs) _ Handles chkOrigineNeoRigolo.Click If m_bMajViaCode Then Exit Sub If Me.chkOrigineNeoRigolo.Checked Then Me.chkOrigineGrecoLatin.Checked = False MajNbMotsLogotron() End Sub Private Sub Sablier(Optional bDesactiver As Boolean = False) ' Me.Cursor : Curseur de la fenêtre ' Cursor.Current : Curseur de l'application If bDesactiver Then Me.Cursor = Cursors.Default Else Me.Cursor = Cursors.WaitCursor End If End Sub Private Sub Activation(bActiver As Boolean) m_msgDelegue.m_bAnnuler = False Me.cmdAnnuler.Enabled = Not bActiver Sablier(bDesactiver:=bActiver) Me.cmdCopier.Enabled = bActiver Me.cmdGo.Enabled = bActiver Me.cmdQuiz.Enabled = bActiver Me.cmdAvert.Enabled = bActiver End Sub Private Sub MajNbMotsLogotron() Dim lstNiv As New List(Of String) Dim sNiveaux$ = "" For Each obj In Me.lbNiveau.SelectedItems sNiveaux &= obj.ToString & " " lstNiv.Add(obj.ToString) Next AfficherTexte("Niveau(x) sélectionné(s) : " & sNiveaux) Dim lstFreq As New List(Of String) Dim sFreq$ = "" For Each obj In Me.lbFreq.SelectedItems Dim sFreqSelAbrege$ = obj.ToString Dim sFreqSelComplet$ = enumFrequenceAbrege.sConv(sFreqSelAbrege) sFreq &= sFreqSelAbrege & " " lstFreq.Add(sFreqSelComplet) Next AfficherTexte("Fréquence(s) sélectionnée(s) : " & sFreq) Dim bGrecoLatin = Me.chkOrigineGrecoLatin.Checked Dim bNeoRigolo = Me.chkOrigineNeoRigolo.Checked Dim iNbPrefixes = m_prefixes.iLireNbSegmentsUniques(lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim iNbSuffixes = m_suffixes.iLireNbSegmentsUniques(lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim lNbPrefixesCombi& = 0 Dim sTxtCombi$ = "" Select Case Me.lbNbPrefixes.Text Case "H", "1" sTxtCombi = iNbPrefixes & " préfixes" lNbPrefixesCombi = iNbPrefixes Case "2" sTxtCombi = iNbPrefixes & " préfixes x " & (iNbPrefixes - 1) & " préfixes" lNbPrefixesCombi = iNbPrefixes * (iNbPrefixes - 1) Case "3" sTxtCombi = iNbPrefixes & " préfixes x " & (iNbPrefixes - 1) & " préfixes x " & (iNbPrefixes - 2) & " préfixes" lNbPrefixesCombi = iNbPrefixes * (iNbPrefixes - 1) * (iNbPrefixes - 2) Case "4" sTxtCombi = iNbPrefixes & " préfixes x " & (iNbPrefixes - 1) & " préfixes x " & (iNbPrefixes - 2) & " préfixes x " & (iNbPrefixes - 3) & " préfixes" lNbPrefixesCombi = CLng(iNbPrefixes) * (iNbPrefixes - 1) * (iNbPrefixes - 2) * (iNbPrefixes - 3) Case "5" sTxtCombi = iNbPrefixes & " préfixes x " & (iNbPrefixes - 1) & " préfixes x " & (iNbPrefixes - 2) & " préfixes x " & (iNbPrefixes - 3) & " préfixes x " & (iNbPrefixes - 4) & " préfixes" lNbPrefixesCombi = CLng(iNbPrefixes) * (iNbPrefixes - 1) * (iNbPrefixes - 2) * (iNbPrefixes - 3) * (iNbPrefixes - 4) End Select Dim lNbCombi& = lNbPrefixesCombi * iNbSuffixes Dim sNbCombi = sFormaterNumeriqueLong(lNbCombi) AfficherTexte(sTxtCombi & " x " & iNbSuffixes & " suffixes = " & sNbCombi & " combinaisons pour le Logotron") AfficherTexte("") If Not Me.chkOrigineGrecoLatin.Checked Then Dim lstPrefixes = m_prefixes.lstSegmentsAutreOrigine(lstNiv, lstFreq, bNeoRigolo) For Each prefixe In lstPrefixes AfficherTexte(prefixe.sAfficher(bPrefixe:=True)) Next Dim lstSuffixes = m_suffixes.lstSegmentsAutreOrigine(lstNiv, lstFreq, bNeoRigolo) For Each suffixe In lstSuffixes AfficherTexte(suffixe.sAfficher(bPrefixe:=False)) Next End If End Sub Private Sub cmdCopier_Click(sender As Object, e As EventArgs) Handles cmdCopier.Click Dim sTxt$ = sLireListBox(lbResultats) If bCopierPressePapier(sTxt) Then _ MsgBox(sMsgCopiePressePapier, MsgBoxStyle.Exclamation, m_sTitreMsg) End Sub Private Sub cmdGo_Click(sender As Object, e As EventArgs) Handles cmdGo.Click Dim sMot$ = "", sExplication$ = "", sDetail$ = "" Dim lstEtym As New List(Of String) ' Les préfixes et suffixes des mots du dictionnaire sont plus nombreux ' ne prendre que ceux qui forme des mots potentiels plausibles Const bComplet As Boolean = False Dim sNbPrefixesSuccessifs$ = Me.lbNbPrefixes.Text Dim lstNiv As New List(Of String) Dim iNumNiv% = 0 For Each obj In Me.lbNiveau.SelectedItems iNumNiv += 1 lstNiv.Add(obj.ToString) Next If iNumNiv = 0 Then Exit Sub Dim lstFreq As New List(Of String) Dim iNumFreq% = 0 For Each obj In Me.lbFreq.SelectedItems iNumFreq += 1 Dim sFreqSelAbrege$ = obj.ToString Dim sFreqSelComplet$ = enumFrequenceAbrege.sConv(sFreqSelAbrege) lstFreq.Add(sFreqSelComplet) Next If iNumFreq = 0 Then Exit Sub Dim bGrecoLatin = Me.chkOrigineGrecoLatin.Checked Dim bNeoRigolo = Me.chkOrigineNeoRigolo.Checked If Not bTirage(bComplet, sNbPrefixesSuccessifs, lstNiv, lstFreq, bGrecoLatin, bNeoRigolo, sMot, sExplication, sDetail, lstEtym) Then Exit Sub AfficherTexte(sMot) AfficherTexte(sExplication) AfficherTexte(sDetail) If lstEtym.Count > 0 Then For Each sEtym In lstEtym AfficherTexte(sEtym) Next End If AfficherTexte("") End Sub Private Sub cmdQuiz_Click(sender As Object, e As EventArgs) Handles cmdQuiz.Click Activation(bActiver:=False) Using frmQuiz0 As New frmQuiz frmQuiz0.StartPosition = FormStartPosition.CenterScreen frmQuiz0.ShowDialog(Me) End Using Activation(bActiver:=True) End Sub End Class frmQuiz.vb Public Class frmQuiz Const bDebugUnicite = False ' Afficher l'unicité si elle existe Const bDebugUniciteSynth = False ' Afficher toujours l'unicité ou le sens, sinon Const iNbMotsExistantsMin% = 20 Const iNbSegmentsMin% = 8 Private m_bAnnuler As Boolean = False Private m_bAttendre As Boolean = False Private m_bMajViaCode As Boolean = False ' Coefficient de bonus lorsque le préfixe et le suffixe sont justes Private Const iCoefBonus% = 3 Private Const sTipsValider$ = "Valider une réponse du quiz" Private Sub frmQuiz_FormClosing(sender As Object, e As FormClosingEventArgs) _ Handles Me.FormClosing m_bAnnuler = True m_bAttendre = False End Sub Private Sub frmQuiz_Load(sender As Object, e As EventArgs) Handles Me.Load Me.ToolTip1.SetToolTip(Me.cmdValider, sTipsValider) m_bMajViaCode = True Me.lbNbQuestions.Text = "5" Me.lbAlternatives.Text = "1" Me.lbNiveau.Text = "1" Me.lbFreq.SetSelected(0, True) Me.lbFreq.SetSelected(1, True) Me.lbFreq.SetSelected(2, True) Me.lbFreq.SetSelected(3, True) m_bMajViaCode = False MajNbMotsQuiz() AfficherMsgBarreMsg("") End Sub Private Sub lbResultats_Click(sender As Object, e As EventArgs) Handles lbResultats.Click AfficherMsgBarreMsg(lbResultats.Text) End Sub Private Sub lbSuffixesPossibles_Click(sender As Object, e As EventArgs) _ Handles lbSuffixesPossibles.Click AfficherMsgBarreMsg(lbSuffixesPossibles.Text) End Sub Private Sub lbPrefixesPossibles_Click(sender As Object, e As EventArgs) _ Handles lbPrefixesPossibles.Click AfficherMsgBarreMsg(lbPrefixesPossibles.Text) End Sub Private Sub Activation(bActiver As Boolean, Optional bToutCtrl As Boolean = False) Me.cmdQuiz.Enabled = bActiver Me.cmdValider.Enabled = False Me.lbNbQuestions.Enabled = bActiver Me.lbAlternatives.Enabled = bActiver Me.lbNiveau.Enabled = bActiver If bToutCtrl Then Me.chkMotsExistants.Enabled = bActiver Me.chkInversion.Enabled = bActiver End If End Sub Private Sub lbNiveau_SelectedValueChanged(sender As Object, e As EventArgs) _ Handles lbNiveau.SelectedValueChanged If m_bMajViaCode Then Exit Sub MajNbMotsQuiz() End Sub Private Sub lbFreq_SelectedValueChanged(sender As Object, e As EventArgs) _ Handles lbFreq.SelectedValueChanged If m_bMajViaCode Then Exit Sub MajNbMotsQuiz() End Sub Private Sub chkMotsExistants_Click(sender As Object, e As EventArgs) Handles chkMotsExistants.Click If m_bMajViaCode Then Exit Sub ' Pour les mots existants, toutes les origines sont incluses ' (sinon il faudrait ajouter l'origine des préfixes et suffixes dans le fichier des mots existants) If Me.chkMotsExistants.Checked Then Me.chkOrigineGrecoLatin.Checked = False If Me.chkMotsExistants.Checked Then Me.chkOrigineNeoRigolo.Checked = False MajNbMotsQuiz() End Sub Private Sub chkOrigineGrecoLatin_Click(sender As Object, e As EventArgs) Handles chkOrigineGrecoLatin.Click If m_bMajViaCode Then Exit Sub ' Si sélectionne les seules origines Greco-latines, ' on ne peut plus se baser sur les mots existants (toutes origines) If Me.chkOrigineGrecoLatin.Checked Then Me.chkMotsExistants.Checked = False If Me.chkOrigineGrecoLatin.Checked Then Me.chkOrigineNeoRigolo.Checked = False MajNbMotsQuiz() End Sub Private Sub chkOrigineNeoRigolo_Click(sender As Object, e As EventArgs) _ Handles chkOrigineNeoRigolo.Click If m_bMajViaCode Then Exit Sub If Me.chkOrigineNeoRigolo.Checked Then Me.chkOrigineGrecoLatin.Checked = False If Me.chkOrigineNeoRigolo.Checked Then Me.chkMotsExistants.Checked = False MajNbMotsQuiz() End Sub Private Sub MajNbMotsQuiz() 'Dim sNiv$ = Me.lbNiveau.SelectedItem 'Dim iNiv% = Integer.Parse(sNiv) Dim lstNiv As New List(Of String) 'lstNiv.Add(sNiv) ' 08/07/2018 Plusieurs niveaux possibles Dim sNiveaux$ = "" For Each obj In Me.lbNiveau.SelectedItems sNiveaux &= obj.ToString & " " lstNiv.Add(obj.ToString) Next 'AfficherTexte("Niveau sélectionné : " & sNiv) AfficherTexte("Niveaux sélectionnés : " & sNiveaux) ' 21/08/2018 Dim lstFreq As New List(Of String) Dim sFreq$ = "" For Each obj In Me.lbFreq.SelectedItems Dim sFreqSelAbrege$ = obj.ToString Dim sFreqSelComplet$ = enumFrequenceAbrege.sConv(sFreqSelAbrege) sFreq &= sFreqSelAbrege & " " lstFreq.Add(sFreqSelComplet) Next AfficherTexte("Fréquence(s) sélectionnée(s) : " & sFreq) Me.cmdQuiz.Enabled = True If Me.chkMotsExistants.Checked Then Dim iNbMotsExistants0% = iNbMotsExistants(lstNiv, lstFreq) Dim sNbMots = sFormaterNumeriqueLong(iNbMotsExistants0) ' 10/07/2020 Dim iNbMotsExistantsTot% = iNbMotsExistantsTotal(lstNiv, lstFreq) Dim sNbMotsTot = sFormaterNumeriqueLong(iNbMotsExistantsTot) AfficherTexte(sNbMots & " mots existants pour le quiz (racines uniques, " & sNbMotsTot & " en tout)") If iNbMotsExistants0 < iNbMotsExistantsMin Then Me.cmdQuiz.Enabled = False Dim iNbPE% = iNbPrefixesMotsExistants(lstNiv, lstFreq) Dim sNbPE = sFormaterNumeriqueLong(iNbPE) AfficherTexte(sNbPE & " préfixes distincts pour les mots existants") Dim iNbSE% = iNbSuffixesMotsExistants(lstNiv, lstFreq) Dim sNbSE = sFormaterNumeriqueLong(iNbSE) AfficherTexte(sNbSE & " suffixes distincts pour les mots existants") Const bDebugMots As Boolean = False If bDebugMots Then Dim i% = 0 For Each mot In lstMotsExistants(lstNiv, lstFreq) i += 1 AfficherTexte(i & " : " & mot.ToString()) If i > 50 Then AfficherTexte("...") Exit For End If Next End If Const bDebugPrefixes As Boolean = False If bDebugPrefixes Then Dim i% = 0 For Each mot In lstPrefixesMotsExistants(lstNiv, lstFreq) i += 1 AfficherTexte(i & " : " & mot.sAfficherPrefixe()) Next End If Const bDebugSuffixes As Boolean = False If bDebugSuffixes Then Dim i% = 0 For Each mot In lstSuffixesMotsExistants(lstNiv, lstFreq) i += 1 AfficherTexte(i & " : " & mot.sAfficherSuffixe()) Next End If Else Dim bGrecoLatin = Me.chkOrigineGrecoLatin.Checked Dim bNeoRigolo = Me.chkOrigineNeoRigolo.Checked Dim iNbPrefixes = m_prefixes.iLireNbSegmentsUniques(lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim iNbSuffixes = m_suffixes.iLireNbSegmentsUniques(lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim lNbCombi& = iNbPrefixes * iNbSuffixes Dim sNbCombi = sFormaterNumeriqueLong(lNbCombi) AfficherTexte(iNbPrefixes & " préfixes" & " x " & iNbSuffixes & " suffixes = " & _ sNbCombi & " combinaisons pour le quiz") If iNbPrefixes < iNbSegmentsMin Then Me.cmdQuiz.Enabled = False If iNbSuffixes < iNbSegmentsMin Then Me.cmdQuiz.Enabled = False End If AfficherTexte("") End Sub 'Private Sub chkInversion_Click(sender As Object, e As EventArgs) Handles chkInversion.Click 'End Sub Private Sub cmdQuiz_Click(sender As Object, e As EventArgs) Handles cmdQuiz.Click m_bAnnuler = False Activation(bActiver:=False) EffacerMessages() AfficherTexte("Préfixe juste : 1 point") AfficherTexte("Suffixe juste : 1 point") AfficherTexte("Préfixe et suffixe juste : 3 points") Dim iNiveau = Integer.Parse(Me.lbNiveau.Text) 'Dim iCoefNiv% = 0 'iNiveau + 1 ' 08/07/2018 Plusieurs niveaux possibles Dim lstNiv As New List(Of String) Dim sNiveaux$ = "" For Each obj In Me.lbNiveau.SelectedItems Dim sNiv$ = obj.ToString lstNiv.Add(sNiv) sNiveaux &= sNiv & " " Next Dim iCoefNiv = enumNiveau.iCoef(sNiveaux) ' 21/08/2018 Dim lstFreq As New List(Of String) Dim sFreq$ = "" For Each obj In Me.lbFreq.SelectedItems Dim sFreqSelAbrege$ = obj.ToString Dim sFreqSelComplet$ = enumFrequenceAbrege.sConv(sFreqSelAbrege) sFreq &= sFreqSelAbrege & " " lstFreq.Add(sFreqSelComplet) Next Dim iCoefFreq = enumFrequenceAbrege.iCoef(sFreq) Dim iNbQuestions = Integer.Parse(Me.lbNbQuestions.Text) Dim iAlternatives = Integer.Parse(Me.lbAlternatives.Text) Dim iScoreTot% = 0 Dim iCoefAlternatives% = iAlternatives + 1 Dim iCoefNBQ% = iNbQuestions For iNumQuestion As Integer = 0 To iNbQuestions - 1 AfficherTexte("") AfficherTexte("Question n°" & iNumQuestion + 1 & " / " & iNbQuestions) If Me.chkInversion.Checked Then Me.ToolTip1.SetToolTip(Me.lbSuffixesPossibles, _ "Choisir le suffixe parmi la liste") Me.ToolTip1.SetToolTip(Me.lbPrefixesPossibles, _ "Choisir le préfixe parmi la liste") Else Me.ToolTip1.SetToolTip(Me.lbSuffixesPossibles, _ "Choisir le sens du suffixe parmi la liste") Me.ToolTip1.SetToolTip(Me.lbPrefixesPossibles, _ "Choisir le sens du préfixe parmi la liste") End If Dim bErreur = False Dim iScore% = 0 If Me.chkInversion.Checked Then If Me.chkMotsExistants.Checked Then QuizSegmentMotExistant(lstNiv, lstFreq, iAlternatives, iScore, bErreur) Else QuizSegment(m_prefixes, m_suffixes, _ lstNiv, lstFreq, iAlternatives, iScore, bErreur) End If Else If Me.chkMotsExistants.Checked Then QuizDefinitionMotExistant(lstNiv, lstFreq, iAlternatives, iScore, bErreur) Else QuizDefinition(m_prefixes, m_suffixes, _ lstNiv, lstFreq, iAlternatives, iScore, bErreur) End If End If If m_bAnnuler Then Exit Sub iScoreTot += iScore Dim sScore$ = "Résultat = " & iScoreTot & " / " & (iNumQuestion + 1) * iCoefBonus AfficherTexte(sScore) If bErreur Then ' Boucle d'attente pour comprendre l'erreur Activation(bActiver:=False, bToutCtrl:=True) Me.cmdValider.Text = "Poursuivre" Me.ToolTip1.SetToolTip(Me.cmdValider, "Poursuivre le quiz") Me.cmdValider.Enabled = True m_bAttendre = True While m_bAttendre If m_bAnnuler Then Exit While Application.DoEvents() End While Me.cmdValider.Text = "Valider" Me.ToolTip1.SetToolTip(Me.cmdValider, sTipsValider) Activation(bActiver:=True, bToutCtrl:=True) Activation(bActiver:=False) ' Mode normale End If Next 'Dim sAffNiv$ = "niveau " & iNiveau Dim sAffNiv$ = "niveau(x) " & sNiveaux & ", " Dim sAffFreq$ = "fréquence(s) " & sFreq If sFreq = "Fréq. Moy. Rare Abs. " Then sAffFreq = "" ' Pas besoin d'afficher la fréquence alors Else sAffFreq &= ", " End If Dim sResultatFinal$ = "Résultat final " & sAffNiv & sAffFreq & _ " et difficulté " & iAlternatives & " avec " & iNbQuestions & " questions = " & _ iScoreTot & " / " & iNbQuestions * iCoefBonus Dim sScoreFinal$ = "Score final = " & iScoreTot * iCoefNiv * iCoefFreq * iCoefAlternatives * iCoefNBQ AfficherTexte(sResultatFinal) AfficherTexte(sScoreFinal) Activation(bActiver:=True) End Sub Private Sub QuizDefinition(basePrefixe As clsBase, baseSuffixe As clsBase, _ lstNiv As List(Of String), lstFreq As List(Of String), iAlternatives%, _ ByRef iScore%, ByRef bErreur As Boolean) ' iNiveau% ' Quiz sur la définition du préfixe et du suffixe iScore = 0 Dim bGrecoLatin = Me.chkOrigineGrecoLatin.Checked Dim bNeoRigolo = Me.chkOrigineNeoRigolo.Checked ' Les préfixes et suffixes des mots du dictionnaire sont plus nombreux ' ne prendre que ceux qui forme des mots potentiels plausibles Const bComplet = False ' 08/07/2018 Plusieurs niveaux Dim iNumPrefixe% = basePrefixe.iTirageSegment(bComplet, lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim prefixe As clsSegmentBase = Nothing If Not basePrefixe.bLireSegment(iNumPrefixe, prefixe) Then Exit Sub Dim sNiveauP = prefixe.sNiveau Dim iNumSuffixe% = baseSuffixe.iTirageSegment(bComplet, lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim suffixe As clsSegmentBase = Nothing If Not baseSuffixe.bLireSegment(iNumSuffixe, suffixe) Then Exit Sub Dim sNiveauS = suffixe.sNiveau Dim sPrefixe = prefixe.sSegment Dim sSuffixe = suffixe.sSegment Dim sPrefixeMaj = sPrefixe.ToUpper() Dim sSuffixeMaj = sSuffixe.ToUpper() Dim sSensPrefixeMaj = prefixe.sSens.ToUpper() sSensPrefixeMaj = sCompleterPrefixe(sSensPrefixeMaj) Dim sEtymPrefixe = prefixe.sEtym Dim sSensSuffixeMaj = suffixe.sSens.ToUpper() Dim sEtymSuffixe = suffixe.sEtym Dim sMot$ = sPrefixeMaj & sSuffixeMaj Dim sDetail$ = sPrefixeMaj & "(" & sNiveauP & ")-" & sSuffixeMaj & "(" & sNiveauS & ")" Dim sExplication$ = sSensSuffixeMaj & " " & sSensPrefixeMaj Dim lstEtym = New List(Of String) If sEtymPrefixe.Length > 0 Then lstEtym.Add(sPrefixe & "- : " & sEtymPrefixe) If sEtymSuffixe.Length > 0 Then lstEtym.Add("-" & sSuffixe & " : " & sEtymSuffixe) Dim itPrefixe As New clsInitTirage(prefixe) Dim itSuffixe As New clsInitTirage(suffixe) If bDebugUnicite Then If prefixe.sUnicite.Length > 0 Then sSensPrefixeMaj &= " [" & prefixe.sUnicite & "]" If suffixe.sUnicite.Length > 0 Then sSensSuffixeMaj &= " [" & suffixe.sUnicite & "]" End If If bDebugUniciteSynth Then sSensPrefixeMaj &= " (" & prefixe.sUniciteSynth & ")" sSensSuffixeMaj &= " (" & suffixe.sUniciteSynth & ")" End If Dim lstExplicationsPrefixe As New List(Of String) lstExplicationsPrefixe.Add(sSensPrefixeMaj) Dim lstExplicationsSuffixe As New List(Of String) lstExplicationsSuffixe.Add(sSensSuffixeMaj) For j As Integer = 0 To iAlternatives - 1 Dim iNumPrefixeAutre% = basePrefixe.iTirageSegment(bComplet, lstNiv, lstFreq, itPrefixe, bGrecoLatin, bNeoRigolo) Dim prefixeP2 As clsSegmentBase = Nothing If Not basePrefixe.bLireSegment(iNumPrefixeAutre, prefixeP2) Then Exit For Dim sSensPrefixeAutre = prefixeP2.sSens.ToUpper() sSensPrefixeAutre = sCompleterPrefixe(sSensPrefixeAutre) Dim iNumSuffixeAutre% = baseSuffixe.iTirageSegment(bComplet, lstNiv, lstFreq, itSuffixe, bGrecoLatin, bNeoRigolo) Dim suffixeS2 As clsSegmentBase = Nothing If Not baseSuffixe.bLireSegment(iNumSuffixeAutre, suffixeS2) Then Exit For Dim sSensSuffixeAutre = suffixeS2.sSens.ToUpper() If bDebugUnicite Then If prefixeP2.sUnicite.Length > 0 Then _ sSensPrefixeAutre &= " [" & prefixeP2.sUnicite & "]" If suffixeS2.sUnicite.Length > 0 Then _ sSensSuffixeAutre &= " [" & suffixeS2.sUnicite & "]" End If If bDebugUniciteSynth Then sSensPrefixeAutre &= " (" & prefixeP2.sUniciteSynth & ")" sSensSuffixeAutre &= " (" & suffixeS2.sUniciteSynth & ")" End If lstExplicationsPrefixe.Add(sSensPrefixeAutre) lstExplicationsSuffixe.Add(sSensSuffixeAutre) Next RemplirListBoxAuHasard(lbPrefixesPossibles, lstExplicationsPrefixe) RemplirListBoxAuHasard(lbSuffixesPossibles, lstExplicationsSuffixe) AfficherTexte(sMot) Me.cmdValider.Enabled = True While Me.cmdValider.Enabled If m_bAnnuler Then Activation(bActiver:=True) Exit Sub End If Application.DoEvents() End While Dim sSensPrefixeChoisi$ = Me.lbPrefixesPossibles.Text Dim sSensSuffixeChoisi$ = Me.lbSuffixesPossibles.Text Dim bPrefixeOk, bSuffixeOk As Boolean bPrefixeOk = False : bSuffixeOk = False If sSensPrefixeChoisi = sSensPrefixeMaj AndAlso _ sSensSuffixeChoisi = sSensSuffixeMaj Then iScore += iCoefBonus : bPrefixeOk = True : bSuffixeOk = True ElseIf sSensPrefixeChoisi = sSensPrefixeMaj Then iScore += 1 : bPrefixeOk = True ElseIf sSensSuffixeChoisi = sSensSuffixeMaj Then iScore += 1 : bSuffixeOk = True End If Dim sAffPrefixe = sSensPrefixeChoisi & " : Faux ! " Dim sAffSuffixe = sSensSuffixeChoisi & " : Faux ! " If sSensPrefixeChoisi.Length = 0 Then sAffPrefixe = "" If sSensSuffixeChoisi.Length = 0 Then sAffSuffixe = "" AfficherTexte(sDetail) If lstEtym.Count > 0 Then For Each sEtym In lstEtym AfficherTexte(sEtym) Next End If bErreur = True If bPrefixeOk AndAlso bSuffixeOk Then AfficherTexte(sExplication & " : Exact !!") bErreur = False ElseIf bPrefixeOk Then AfficherTexte(sSensPrefixeMaj & " : Exact !") AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) ElseIf bSuffixeOk Then AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sSensSuffixeMaj & " : Exact !") Else AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) End If End Sub Private Sub QuizDefinitionMotExistant( lstNiv As List(Of String), lstFreq As List(Of String), iAlternatives%, _ ByRef iScore%, ByRef bErreur As Boolean) ' Quiz sur la définition du préfixe et du suffixe iScore = 0 Dim prefixe As clsSegmentBase = Nothing Dim suffixe As clsSegmentBase = Nothing Dim iNumMotExistant = iTirageMotExistant(lstNiv, lstFreq, prefixe, suffixe) If iNumMotExistant = iTirageImpossible Then Exit Sub Dim sNiveauP = prefixe.sNiveau Dim sNiveauS = suffixe.sNiveau Dim sPrefixe = prefixe.sSegment Dim sPrefixeElision = prefixe.sSegmentElision Dim sSuffixe = suffixe.sSegment 'Dim sPrefixeMaj = sPrefixe.ToUpper() Dim sPrefixeMaj = sPrefixeElision.ToUpper() ' 28/04/2019 Dim sSuffixeMaj = sSuffixe.ToUpper() Dim sSensPrefixeMaj = prefixe.sSens.ToUpper() sSensPrefixeMaj = sCompleterPrefixe(sSensPrefixeMaj) prefixe.sEtym = m_prefixes.sTrouverEtymologie(sPrefixe, prefixe.sUniciteSynth) ' 10/05/2018 Dim sEtymPrefixe = prefixe.sEtym Dim sSensSuffixeMaj = suffixe.sSens.ToUpper() suffixe.sEtym = m_suffixes.sTrouverEtymologie(sSuffixe, suffixe.sUniciteSynth) ' 10/05/2018 Dim sEtymSuffixe = suffixe.sEtym Dim sMot$ = sPrefixeMaj & sSuffixeMaj Dim sDetail$ = sPrefixeMaj & "(" & sNiveauP & ")-" & sSuffixeMaj & "(" & sNiveauS & ")" Dim sExplication$ = sSensSuffixeMaj & " " & sSensPrefixeMaj Dim lstEtym = New List(Of String) If sEtymPrefixe.Length > 0 Then lstEtym.Add(sPrefixe & "- : " & sEtymPrefixe) If sEtymSuffixe.Length > 0 Then lstEtym.Add("-" & sSuffixe & " : " & sEtymSuffixe) Dim lstNumMotExistant As New List(Of Integer) Dim itPrefixe As New clsInitTirage(prefixe) Dim itSuffixe As New clsInitTirage(suffixe) Dim lstExplicationsPrefixe As New List(Of String) If bDebugUnicite Then Debug.WriteLine("iNumMotExistant = " & iNumMotExistant) If prefixe.sUnicite.Length > 0 Then sSensPrefixeMaj &= " [" & prefixe.sUnicite & "]" If suffixe.sUnicite.Length > 0 Then sSensSuffixeMaj &= " [" & suffixe.sUnicite & "]" End If If bDebugUniciteSynth Then Debug.WriteLine("iNumMotExistant = " & iNumMotExistant) sSensPrefixeMaj &= " (" & prefixe.sUniciteSynth & ")" sSensSuffixeMaj &= " (" & suffixe.sUniciteSynth & ")" End If lstExplicationsPrefixe.Add(sSensPrefixeMaj) Dim lstExplicationsSuffixe As New List(Of String) lstExplicationsSuffixe.Add(sSensSuffixeMaj) For j As Integer = 0 To iAlternatives - 1 Dim motAutre As clsMotExistant = Nothing Dim iNumMotExistantAutre = iTirageMotExistantAutre(lstNiv, lstFreq, iNumMotExistant, _ itPrefixe, itSuffixe, lstNumMotExistant, motAutre) If iNumMotExistantAutre = iTirageImpossible Then Exit For If IsNothing(motAutre) Then Exit For Dim sDefPrefixe = motAutre.sDefPrefixe Dim sDefSuffixe = motAutre.sDefSuffixe If bDebugUnicite Then If motAutre.sUnicitePrefixe.Length > 0 Then _ sDefPrefixe &= " [" & motAutre.sUnicitePrefixe & "]" If motAutre.sUniciteSuffixe.Length > 0 Then _ sDefSuffixe &= " [" & motAutre.sUniciteSuffixe & "]" End If If bDebugUniciteSynth Then sDefPrefixe &= " (" & motAutre.sUnicitePrefixeSynth & ")" sDefSuffixe &= " (" & motAutre.sUniciteSuffixeSynth & ")" End If lstExplicationsPrefixe.Add(sDefPrefixe) lstExplicationsSuffixe.Add(sDefSuffixe) Next RemplirListBoxAuHasard(lbPrefixesPossibles, lstExplicationsPrefixe) RemplirListBoxAuHasard(lbSuffixesPossibles, lstExplicationsSuffixe) AfficherTexte(sMot) Me.cmdValider.Enabled = True While Me.cmdValider.Enabled If m_bAnnuler Then Activation(bActiver:=True) Exit Sub End If Application.DoEvents() End While Dim sSensPrefixeChoisi$ = Me.lbPrefixesPossibles.Text Dim sSensSuffixeChoisi$ = Me.lbSuffixesPossibles.Text Dim bPrefixeOk, bSuffixeOk As Boolean bPrefixeOk = False : bSuffixeOk = False If sSensPrefixeChoisi = sSensPrefixeMaj AndAlso _ sSensSuffixeChoisi = sSensSuffixeMaj Then iScore += iCoefBonus : bPrefixeOk = True : bSuffixeOk = True ElseIf sSensPrefixeChoisi = sSensPrefixeMaj Then iScore += 1 : bPrefixeOk = True ElseIf sSensSuffixeChoisi = sSensSuffixeMaj Then iScore += 1 : bSuffixeOk = True End If Dim sAffPrefixe = sSensPrefixeChoisi & " : Faux ! " Dim sAffSuffixe = sSensSuffixeChoisi & " : Faux ! " If sSensPrefixeChoisi.Length = 0 Then sAffPrefixe = "" If sSensSuffixeChoisi.Length = 0 Then sAffSuffixe = "" AfficherTexte(sDetail) If lstEtym.Count > 0 Then For Each sEtym In lstEtym AfficherTexte(sEtym) Next End If bErreur = True If bPrefixeOk AndAlso bSuffixeOk Then AfficherTexte(sExplication & " : Exact !!") bErreur = False ElseIf bPrefixeOk Then AfficherTexte(sSensPrefixeMaj & " : Exact !") AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) ElseIf bSuffixeOk Then AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sSensSuffixeMaj & " : Exact !") Else AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) End If End Sub Private Sub QuizSegment(basePrefixe As clsBase, baseSuffixe As clsBase, _ lstNiv As List(Of String), lstFreq As List(Of String), iAlternatives%, _ ByRef iScore%, ByRef bErreur As Boolean) ' Quiz sur le préfixe et le suffixe correspondant à une définition iScore = 0 Dim bGrecoLatin = Me.chkOrigineGrecoLatin.Checked Dim bNeoRigolo = Me.chkOrigineNeoRigolo.Checked ' Les préfixes et suffixes des mots du dictionnaire sont plus nombreux ' ne prendre que ceux qui forme des mots potentiels plausibles Const bComplet = False Dim iNumPrefixe% = basePrefixe.iTirageSegment(bComplet, lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim prefixe As clsSegmentBase = Nothing If Not basePrefixe.bLireSegment(iNumPrefixe, prefixe) Then Exit Sub Dim sNiveauP = prefixe.sNiveau Dim iNumSuffixe% = baseSuffixe.iTirageSegment(bComplet, lstNiv, lstFreq, bGrecoLatin, bNeoRigolo) Dim suffixe As clsSegmentBase = Nothing If Not baseSuffixe.bLireSegment(iNumSuffixe, suffixe) Then Exit Sub Dim sNiveauS = suffixe.sNiveau Dim sPrefixe = prefixe.sSegment Dim sSuffixe = suffixe.sSegment Dim sPrefixeMaj = sPrefixe.ToUpper() Dim sSuffixeMaj = sSuffixe.ToUpper() Dim sSensPrefixe = prefixe.sSens Dim sSensPrefixeMaj = sSensPrefixe.ToUpper() sSensPrefixeMaj = sCompleterPrefixe(sSensPrefixeMaj) Dim sEtymPrefixe = prefixe.sEtym Dim sSensSuffixe = suffixe.sSens Dim sSensSuffixeMaj = sSensSuffixe.ToUpper() Dim sEtymSuffixe = suffixe.sEtym Dim sMot$ = sPrefixeMaj & sSuffixeMaj Dim sDetail$ = sPrefixeMaj & "(" & sNiveauP & ")-" & sSuffixeMaj & "(" & sNiveauS & ")" Dim sExplication$ = sSensSuffixeMaj & " " & sSensPrefixeMaj Dim sPrefixeMajT$ = sPrefixeMaj & "-" Dim sTSuffixeMaj$ = "-" & sSuffixeMaj Dim lstEtym = New List(Of String) If sEtymPrefixe.Length > 0 Then lstEtym.Add(sPrefixe & "- : " & sEtymPrefixe) If sEtymSuffixe.Length > 0 Then lstEtym.Add("-" & sSuffixe & " : " & sEtymSuffixe) If bDebugUnicite Then If prefixe.sUnicite.Length > 0 Then sPrefixeMajT &= " (" & prefixe.sUnicite & ")" If suffixe.sUnicite.Length > 0 Then sTSuffixeMaj &= " (" & suffixe.sUnicite & ")" End If If bDebugUniciteSynth Then sPrefixeMajT &= " (" & prefixe.sUniciteSynth & ")" sTSuffixeMaj &= " (" & suffixe.sUniciteSynth & ")" End If Dim itPrefixe As New clsInitTirage(prefixe) Dim lstPrefixesMajT As New List(Of String) lstPrefixesMajT.Add(sPrefixeMajT) Dim itSuffixe As New clsInitTirage(suffixe) Dim lstSuffixesTMaj As New List(Of String) lstSuffixesTMaj.Add(sTSuffixeMaj) For j As Integer = 0 To iAlternatives - 1 Dim iNumPrefixeAutre% = basePrefixe.iTirageSegment(bComplet, lstNiv, lstFreq, itPrefixe, bGrecoLatin, bNeoRigolo) Dim prefixeP2 As clsSegmentBase = Nothing If Not basePrefixe.bLireSegment(iNumPrefixeAutre, prefixeP2) Then Exit For Dim iNumSuffixeAutre% = baseSuffixe.iTirageSegment(bComplet, lstNiv, lstFreq, itSuffixe, bGrecoLatin, bNeoRigolo) Dim suffixeS2 As clsSegmentBase = Nothing If Not baseSuffixe.bLireSegment(iNumSuffixeAutre, suffixeS2) Then Exit For Dim sPrefixeAutre$ = prefixeP2.sSegment.ToUpper() & "-" Dim sSuffixeAutre$ = "-" & suffixeS2.sSegment.ToUpper() If bDebugUnicite Then If prefixeP2.sUnicite.Length > 0 Then _ sPrefixeAutre &= " [" & prefixeP2.sUnicite & "]" If suffixeS2.sUnicite.Length > 0 Then _ sSuffixeAutre &= " [" & suffixeS2.sUnicite & "]" End If If bDebugUniciteSynth Then sPrefixeAutre &= " (" & prefixeP2.sUniciteSynth & ")" sSuffixeAutre &= " (" & suffixeS2.sUniciteSynth & ")" End If lstPrefixesMajT.Add(sPrefixeAutre) lstSuffixesTMaj.Add(sSuffixeAutre) Next RemplirListBoxAuHasard(lbPrefixesPossibles, lstPrefixesMajT) RemplirListBoxAuHasard(lbSuffixesPossibles, lstSuffixesTMaj) AfficherTexte(sExplication) Me.cmdValider.Enabled = True While Me.cmdValider.Enabled If m_bAnnuler Then Activation(bActiver:=True) Exit Sub End If Application.DoEvents() End While Dim sPrefixeChoisi$ = Me.lbPrefixesPossibles.Text Dim sSuffixeChoisi$ = Me.lbSuffixesPossibles.Text Dim bPrefixeOk, bSuffixeOk As Boolean bPrefixeOk = False : bSuffixeOk = False If sPrefixeChoisi = sPrefixeMajT AndAlso _ sSuffixeChoisi = sTSuffixeMaj Then iScore += iCoefBonus : bPrefixeOk = True : bSuffixeOk = True ElseIf sPrefixeChoisi = sPrefixeMajT Then iScore += 1 : bPrefixeOk = True ElseIf sSuffixeChoisi = sTSuffixeMaj Then iScore += 1 : bSuffixeOk = True End If Dim sAffPrefixe = sPrefixeChoisi & " : Faux ! " Dim sAffSuffixe = sSuffixeChoisi & " : Faux ! " If sPrefixeChoisi.Length = 0 Then sAffPrefixe = "" If sSuffixeChoisi.Length = 0 Then sAffSuffixe = "" AfficherTexte(sDetail) If lstEtym.Count > 0 Then For Each sEtym In lstEtym AfficherTexte(sEtym) Next End If bErreur = True If bPrefixeOk AndAlso bSuffixeOk Then AfficherTexte(sMot & " : Exact !!") bErreur = False ElseIf bPrefixeOk Then AfficherTexte(sPrefixeMaj & " : Exact !") AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) ElseIf bSuffixeOk Then AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sSensSuffixeMaj & " : Exact !") Else AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) End If End Sub Private Sub QuizSegmentMotExistant( lstNiv As List(Of String), lstFreq As List(Of String), iAlternatives%, _ ByRef iScore%, ByRef bErreur As Boolean) ' Quiz sur le préfixe et le suffixe correspondant à une définition iScore = 0 Dim prefixe As clsSegmentBase = Nothing Dim suffixe As clsSegmentBase = Nothing Dim iNumMotExistant = iTirageMotExistant(lstNiv, lstFreq, prefixe, suffixe) If iNumMotExistant = iTirageImpossible Then Exit Sub Dim sNiveauP = prefixe.sNiveau Dim sNiveauS = suffixe.sNiveau Dim sPrefixe = prefixe.sSegment Dim sPrefixeElision = prefixe.sSegmentElision Dim sSuffixe = suffixe.sSegment 'Dim sPrefixeMaj = sPrefixe.ToUpper() Dim sPrefixeMaj = sPrefixeElision.ToUpper() ' 28/04/2019 Dim sSuffixeMaj = sSuffixe.ToUpper() Dim sSensPrefixe = prefixe.sSens Dim sSensPrefixeMaj = sSensPrefixe.ToUpper() sSensPrefixeMaj = sCompleterPrefixe(sSensPrefixeMaj) prefixe.sEtym = m_prefixes.sTrouverEtymologie(sPrefixe, prefixe.sUniciteSynth) ' 10/05/2018 Dim sEtymPrefixe = prefixe.sEtym Dim sSensSuffixe = suffixe.sSens Dim sSensSuffixeMaj = sSensSuffixe.ToUpper() suffixe.sEtym = m_suffixes.sTrouverEtymologie(sSuffixe, suffixe.sUniciteSynth) ' 10/05/2018 Dim sEtymSuffixe = suffixe.sEtym Dim sMot$ = sPrefixeMaj & sSuffixeMaj Dim sDetail$ = sPrefixeMaj & "(" & sNiveauP & ")-" & sSuffixeMaj & "(" & sNiveauS & ")" Dim sExplication$ = sSensSuffixeMaj & " " & sSensPrefixeMaj Dim sPrefixeMajT$ = sPrefixeMaj & "-" Dim sTSuffixeMaj$ = "-" & sSuffixeMaj Dim lstEtym = New List(Of String) If sEtymPrefixe.Length > 0 Then lstEtym.Add(sPrefixe & "- : " & sEtymPrefixe) If sEtymSuffixe.Length > 0 Then lstEtym.Add("-" & sSuffixe & " : " & sEtymSuffixe) If bDebugUnicite Then If prefixe.sUnicite.Length > 0 Then sPrefixeMajT &= " [" & prefixe.sUnicite & "]" If suffixe.sUnicite.Length > 0 Then sTSuffixeMaj &= " [" & suffixe.sUnicite & "]" End If If bDebugUniciteSynth Then sPrefixeMajT &= " (" & prefixe.sUniciteSynth & ")" sTSuffixeMaj &= " (" & suffixe.sUniciteSynth & ")" End If Dim lstPrefixesMajT As New List(Of String) lstPrefixesMajT.Add(sPrefixeMajT) Dim lstSuffixesTMaj As New List(Of String) lstSuffixesTMaj.Add(sTSuffixeMaj) Dim lstNumMotExistant As New List(Of Integer) Dim itPrefixe As New clsInitTirage(prefixe) Dim itSuffixe As New clsInitTirage(suffixe) For j As Integer = 0 To iAlternatives - 1 Dim motAutre As clsMotExistant = Nothing Dim iNumMotExistantAutre = iTirageMotExistantAutre(lstNiv, lstFreq, iNumMotExistant, _ itPrefixe, itSuffixe, lstNumMotExistant, motAutre) If iNumMotExistantAutre = iTirageImpossible Then Exit For If IsNothing(motAutre) Then Exit For Dim sDefPrefixe = motAutre.sPrefixe.ToUpper() & "-" Dim sDefSuffixe = "-" & motAutre.sSuffixe.ToUpper() If bDebugUnicite Then If motAutre.sUnicitePrefixe.Length > 0 Then _ sDefPrefixe &= " [" & motAutre.sUnicitePrefixe & "]" If motAutre.sUniciteSuffixe.Length > 0 Then _ sDefSuffixe &= " [" & motAutre.sUniciteSuffixe & "]" End If If bDebugUniciteSynth Then sDefPrefixe &= " (" & motAutre.sUnicitePrefixeSynth & ")" sDefSuffixe &= " (" & motAutre.sUniciteSuffixeSynth & ")" End If lstPrefixesMajT.Add(sDefPrefixe) lstSuffixesTMaj.Add(sDefSuffixe) Next RemplirListBoxAuHasard(lbPrefixesPossibles, lstPrefixesMajT) RemplirListBoxAuHasard(lbSuffixesPossibles, lstSuffixesTMaj) AfficherTexte(sExplication) Me.cmdValider.Enabled = True While Me.cmdValider.Enabled If m_bAnnuler Then Activation(bActiver:=True) Exit Sub End If Application.DoEvents() End While Dim sPrefixeChoisi$ = Me.lbPrefixesPossibles.Text Dim sSuffixeChoisi$ = Me.lbSuffixesPossibles.Text Dim bPrefixeOk, bSuffixeOk As Boolean bPrefixeOk = False : bSuffixeOk = False If sPrefixeChoisi = sPrefixeMajT AndAlso _ sSuffixeChoisi = sTSuffixeMaj Then iScore += iCoefBonus : bPrefixeOk = True : bSuffixeOk = True ElseIf sPrefixeChoisi = sPrefixeMajT Then iScore += 1 : bPrefixeOk = True ElseIf sSuffixeChoisi = sTSuffixeMaj Then iScore += 1 : bSuffixeOk = True End If Dim sAffPrefixe = sPrefixeChoisi & " : Faux ! " Dim sAffSuffixe = sSuffixeChoisi & " : Faux ! " If sPrefixeChoisi.Length = 0 Then sAffPrefixe = "" If sSuffixeChoisi.Length = 0 Then sAffSuffixe = "" AfficherTexte(sDetail) If lstEtym.Count > 0 Then For Each sEtym In lstEtym AfficherTexte(sEtym) Next End If bErreur = True If bPrefixeOk AndAlso bSuffixeOk Then AfficherTexte(sMot & " : Exact !!") bErreur = False ElseIf bPrefixeOk Then AfficherTexte(sPrefixeMaj & " : Exact !") AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) ElseIf bSuffixeOk Then AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sSensSuffixeMaj & " : Exact !") Else AfficherTexte(sAffPrefixe & "Réponse = " & sPrefixe & "- : " & sSensPrefixeMaj) AfficherTexte(sAffSuffixe & "Réponse = -" & sSuffixe & " : " & sSensSuffixeMaj) End If End Sub Private m_iIndex% = 0 Private Sub AfficherTexte(sTxt$) AfficherTexteListBox(sTxt$, m_iIndex, Me, Me.lbResultats) AfficherMsgBarreMsg(sTxt) End Sub Private Sub EffacerMessages() lbResultats.Items.Clear() m_iIndex = 0 End Sub Private Sub AfficherMsgBarreMsg(sTxt$) Me.ToolStripStatusLabelBarreMsg.Text = sTxt End Sub Private Sub cmdValider_Click(sender As Object, e As EventArgs) Handles cmdValider.Click If m_bAttendre Then m_bAttendre = False Exit Sub End If Me.cmdValider.Enabled = False End Sub Private Sub cmdCopier_Click(sender As Object, e As EventArgs) Handles cmdCopier.Click Dim sTxt$ = sLireListBox(lbResultats) If bCopierPressePapier(sTxt) Then _ MsgBox(sMsgCopiePressePapier, MsgBoxStyle.Exclamation, m_sTitreMsg) End Sub End Class _modConst.vb Module _modConst #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 ReadOnly sNomAppli$ = My.Application.Info.Title Public ReadOnly m_sTitreMsg$ = sNomAppli Private Const sDateVersionLogotron$ = "04/08/2020" Public Const sDateVersionAppli$ = sDateVersionLogotron Public ReadOnly sVersionAppli$ = My.Application.Info.Version.Major & "." & My.Application.Info.Version.Minor & My.Application.Info.Version.Build Public ReadOnly sModeLecture$ = enumModeLecture.sCsv 'Public ReadOnly sModeLecture$ = enumModeLecture.sCode 'Public ReadOnly sModeLecture$ = enumModeLecture.sJSon Public ReadOnly sModeLectureMotsExistants$ = enumModeLectureMotExistant.sCsv 'Public ReadOnly sModeLectureMotsExistants$ = enumModeLectureMotExistant.sCode Public Const sHasard$ = "H" Public Const sCarSautDeLigne$ = "↲" Public Const iIndiceNulString% = -1 End Module modConstLogotron.vb Module modConstLogotron Public Const sGm$ = """" Public Const sFormatPC$ = "0 %" Public Const sFormatPC1$ = "0.0 %" Public Const sFormatPC2$ = "0.00 %" Public Const sFormatPC4$ = "0.0000 %" Public Const sSelectLogotron = "L" Public Const sSelectDictionnaire = "D" Public Const iNonSelect% = 0 Public Const iSelectDictionnaire% = 1 Public Const iSelectLogotron% = 2 Public Const sNonSelectNum$ = "0" Public Const sSelectDictionnaireNum$ = "1" Public Const sSelectLogotronNum$ = "2" ' Séparateur entre la définition du suffixe et celle(s) du(des) préfixe(s) Public Const sSepDef$ = " " Public ReadOnly sLang$ = enumLangue.Fr 'Public ReadOnly sLang$ = enumLangue.En ' Ok si sModeLecture = enumModeLecture.sCsv ' Si sModeLecture = enumModeLecture.sCode, on ne peut pas exclure cela (sauf au tirage) : Public Const bInclureNeologismesAmusants As Boolean = True Public Const sMsgCopiePressePapier$ = "Le texte a été copié dans le presse papier !" Public Const bDebugElision As Boolean = False Public Const bElision As Boolean = True ' 28/04/2019 Public Const sCarElisionO$ = "(o)" Public Const sCarO$ = "o" Public Const iLongPrefixeMinElision% = 2 End Module modEnum.vb Public Class enumModeLecture Public Const sCsv$ = "Csv" Public Const sCode$ = "Code" Public Const sJSon$ = "JSon" End Class Public Class enumModeLectureMotExistant Public Const sCsv$ = "Csv" Public Const sCode$ = "Code" ' Liste incomplète, simple test 'Public Const sJSon$ = "JSon" End Class Public Class enumLangue Public Const Fr$ = "_fr" ' Français Public Const En$ = "_en" ' English End Class Public Class enumNiveau Public Const N1$ = "1" Public Const N2$ = "2" Public Const N3$ = "3" Public Shared Function iCoef%(sNiveaux$) Dim iCoefNiv% = 0 Select Case sNiveaux Case "1 " : iCoefNiv = 1 Case "1 2 " : iCoefNiv = 2 Case "2 " : iCoefNiv = 3 Case "1 2 3 " : iCoefNiv = 5 Case "1 3 " : iCoefNiv = 6 Case "2 3 " : iCoefNiv = 8 Case "3 " : iCoefNiv = 10 Case Else : If bDebug Then Stop End Select Return iCoefNiv End Function End Class Public Class enumFrequence Public Const Frequent$ = "Frequent" Public Const Moyen$ = "Moyen" Public Const Rare$ = "Rare" Public Const Absent$ = "Absent" ' Impossible, sauf si les fréquences ne sont plus à jour Public Const Defaut$ = Frequent End Class Public Class enumFrequenceAbrege Public Const Frequent$ = "Fréq." Public Const Moyen$ = "Moy." Public Const Rare$ = "Rare" Public Const Absent$ = "Abs." Public Shared Function sConv$(sFreqAbrege$) Dim sFreqComplet$ = "" Select Case sFreqAbrege Case enumFrequenceAbrege.Frequent : sFreqComplet = enumFrequence.Frequent Case enumFrequenceAbrege.Moyen : sFreqComplet = enumFrequence.Moyen Case enumFrequenceAbrege.Rare : sFreqComplet = enumFrequence.Rare Case enumFrequenceAbrege.Absent : sFreqComplet = enumFrequence.Absent Case Else : If bDebug Then Stop End Select Return sFreqComplet End Function Public Shared Function iCoef%(sFrequences$) Dim iCoefFreq% = 0 Select Case sFrequences Case "Fréq. " : iCoefFreq = 1 Case "Fréq. Abs. " : iCoefFreq = 1 Case "Fréq. Moy. " : iCoefFreq = 2 Case "Fréq. Moy. Abs. " : iCoefFreq = 2 Case "Moy. " : iCoefFreq = 3 Case "Moy. Abs. " : iCoefFreq = 3 Case "Fréq. Moy. Rare " : iCoefFreq = 5 Case "Fréq. Moy. Rare Abs. " : iCoefFreq = 5 Case "Fréq. Rare " : iCoefFreq = 6 Case "Fréq. Rare Abs. " : iCoefFreq = 6 Case "Moy. Rare " : iCoefFreq = 8 Case "Moy. Rare Abs. " : iCoefFreq = 8 Case "Rare " : iCoefFreq = 10 Case "Rare Abs. " : iCoefFreq = 10 Case "Abs. " : iCoefFreq = 10 Case Else : If bDebug Then Stop End Select Return iCoefFreq End Function End Class Public Class enumOrigine Public Const sGrec$ = "Grec" Public Const sLatin$ = "Latin" Public Const sAutre$ = "Autre" ' Danois, Italien, Anglais, ... Public Const sNonPrecise$ = "Non précisé" Public Const sGrecoLatin$ = "Gréco-latin" Public Const sNeologismeAmusant$ = "Néologisme amusant" ' Fiscalo- Public Const sDefaut$ = sGrecoLatin End Class clsBase.vb Imports System.Text Public Module modBase Public Const iNbColonnes% = 8 ' 01/07/2018 Fréquence ajoutée Public Const iTirageImpossible% = -1 Public m_prefixes As clsBase, m_suffixes As clsBase Public m_defFls As clsDefExclusives #Region "Mots existants" Public Class clsMotExistant Public Const iNbColonnesME% = 10 Public Const iColMot% = 0 Public Const iColDef% = 1 Public Const iColPrefixe% = 2 Public Const iColSuffixe% = 3 Public Const iColNivPrefixe% = 4 Public Const iColNivSuffixe% = 5 Public Const iColUnicitePrefixe% = 6 Public Const iColUniciteSuffixe% = 7 Public Const iColFreqPrefixe% = 8 Public Const iColFreqSuffixe% = 9 Public sMot$, sDef$, sPrefixe$, sSuffixe$, sDefPrefixe$, sDefSuffixe$, sNivPrefixe$, sNivSuffixe$, sUnicitePrefixe$, sUniciteSuffixe$ Public sUnicitePrefixeSynth$, sUniciteSuffixeSynth$ Public sFreqPrefixe$, sFreqSuffixe$ Public iNivPrefixe%, iNivSuffixe% Public iNumMotExistant% Public bElisionPrefixe As Boolean ' bElisionSuffixe Public Sub New() End Sub Public Sub New(sMot$, sDef$, sPrefixe$, sSuffixe$, sDefPrefixe$, sDefSuffixe$, sNivPrefixe$, sNivSuffixe$, sUnicitePrefixe$, sUniciteSuffixe$, iNumMot%, sFreqPrefixe$, sFreqSuffixe$, bElisionPrefixe As Boolean) Me.sMot = sMot Me.sDef = sDef Me.sPrefixe = sPrefixe Me.sSuffixe = sSuffixe Me.sDefPrefixe = sDefPrefixe Me.sDefSuffixe = sDefSuffixe Me.sNivPrefixe = sNivPrefixe Me.sNivSuffixe = sNivSuffixe Me.iNivPrefixe = Integer.Parse(Me.sNivPrefixe) Me.iNivSuffixe = Integer.Parse(Me.sNivSuffixe) Me.sUnicitePrefixe = sUnicitePrefixe Me.sUniciteSuffixe = sUniciteSuffixe Me.iNumMotExistant = iNumMot Me.sFreqPrefixe = sFreqPrefixe Me.sFreqSuffixe = sFreqSuffixe Me.bElisionPrefixe = bElisionPrefixe 'Me.bElisionSuffixe = bElisionSuffixe Synthese() End Sub Public Sub Synthese() Dim sSensPrefixeSansArticle$ = sSupprimerArticle(sDefPrefixe) Me.sUnicitePrefixeSynth = sSensPrefixeSansArticle If sUnicitePrefixe.Length > 0 Then Me.sUnicitePrefixeSynth = sUnicitePrefixe Dim sSensSuffixeSansArticle$ = sSupprimerArticle(sDefSuffixe) Me.sUniciteSuffixeSynth = sSensSuffixeSansArticle If sUniciteSuffixe.Length > 0 Then Me.sUniciteSuffixeSynth = sUniciteSuffixe End Sub Public Shared Sub ParserDefinition(sDef$, ByRef sDefSuffixe$, ByRef sDefPrefixe$) Dim asChamps2$() = sDef.Split(New String() {sSepDef}, StringSplitOptions.None) Dim iNbChamps2% = asChamps2.GetUpperBound(0) + 1 sDefSuffixe = Nothing sDefPrefixe = Nothing If iNbChamps2 >= 1 Then sDefSuffixe = asChamps2(0).Trim If iNbChamps2 >= 2 Then sDefPrefixe = asChamps2(1).Trim End Sub Public Sub ParserDefinition() Dim asChamps2$() = Me.sDef.Split(New String() {sSepDef}, StringSplitOptions.None) Dim iNbChamps2% = asChamps2.GetUpperBound(0) + 1 Me.sDefSuffixe = Nothing Me.sDefPrefixe = Nothing If iNbChamps2 >= 1 Then Me.sDefSuffixe = asChamps2(0).Trim If iNbChamps2 >= 2 Then Me.sDefPrefixe = asChamps2(1).Trim End Sub Public Overrides Function ToString$() Dim sDef$ = Me.sDefSuffixe.ToUpper & sSepDef & sCompleterPrefixe(Me.sDefPrefixe.ToUpper) Dim sTxt$ = Me.sMot & " : " & sDef & " : " & Me.sPrefixe & "(" & Me.sNivPrefixe & ")-" & Me.sSuffixe & "(" & Me.sNivSuffixe & ")" If Me.sUnicitePrefixe.Length > 0 Then sTxt &= " (unicité préfixe : " & Me.sUnicitePrefixe & ")" If Me.sUniciteSuffixe.Length > 0 Then sTxt &= " (unicité suffixe : " & Me.sUniciteSuffixe & ")" Return sTxt End Function Public Function sAfficherPrefixe$() Dim sDef$ = Me.sDefSuffixe.ToUpper & sSepDef & sCompleterPrefixe(Me.sDefPrefixe.ToUpper) Dim sTxt$ = Me.sPrefixe & "-" & " (" & Me.sMot & " : " & sDef & " : " & Me.sPrefixe & "(" & Me.sNivPrefixe & ") " & Me.sSuffixe & "(" & Me.sNivSuffixe & "))" If Me.sUnicitePrefixe.Length > 0 Then sTxt &= " (unicité préfixe : " & Me.sUnicitePrefixe & ")" If Me.sUniciteSuffixe.Length > 0 Then sTxt &= " (unicité suffixe : " & Me.sUniciteSuffixe & ")" Return sTxt End Function Public Function sAfficherSuffixe$() Dim sDef$ = Me.sDefSuffixe.ToUpper & sSepDef & sCompleterPrefixe(Me.sDefPrefixe.ToUpper) Dim sTxt$ = "-" & Me.sSuffixe & " (" & Me.sMot & " : " & sDef & " : " & Me.sPrefixe & "(" & Me.sNivPrefixe & ") " & Me.sSuffixe & "(" & Me.sNivSuffixe & "))" If Me.sUnicitePrefixe.Length > 0 Then sTxt &= " (unicité préfixe : " & Me.sUnicitePrefixe & ")" If Me.sUniciteSuffixe.Length > 0 Then sTxt &= " (unicité suffixe : " & Me.sUniciteSuffixe & ")" Return sTxt End Function End Class Public m_dicoMotsExistants As Dictionary(Of String, clsMotExistant) Public Sub ChargerMotsExistantsCsv() m_dicoMotsExistants = New Dictionary(Of String, clsMotExistant) Dim sChemin$ = Application.StartupPath & "\MotsSimples" & sLang & ".csv" If Not bFichierExiste(sChemin, bPrompt:=True) Then Exit Sub Dim sb As New StringBuilder Const bFiltrer As Boolean = False Const rTauxFiltre! = 0.02 Dim asLignes$() = asLireFichier(sChemin) Dim iNumLigne% = 0 Dim iNumMot% = 0 For Each sLigne In asLignes iNumLigne += 1 If iNumLigne < 2 Then Continue For ' 1 ligne d'entête If bFiltrer Then Dim r = rRandomiser() If r < rTauxFiltre OrElse sLigne.IndexOf("MÉDECIN") > 0 Then _ sb.AppendLine(sLigne) End If Dim asChamps$() = sLigne.Split(";"c) ' ":"c Dim iNbChamps% = asChamps.GetUpperBound(0) + 1 Dim sMot$, sDef$, sDecoup$, sPrefixe$, sSuffixe$, sDefPrefixe$, sDefSuffixe$ Dim sNivPrefixe$, sNivSuffixe$, sUnicitePrefixe$, sUniciteSuffixe$ Dim sFreqPrefixe$, sFreqSuffixe$ Dim bElisionPrefixe As Boolean ' bElisionSuffixe sMot = "" : sDef = "" : sDecoup = "" : sPrefixe = "" : sSuffixe = "" sDefPrefixe = "" : sDefSuffixe = "" sNivPrefixe = "" : sNivSuffixe = "" sUnicitePrefixe = "" : sUniciteSuffixe = "" sFreqPrefixe = "" : sFreqSuffixe = "" bElisionPrefixe = False ': bElisionSuffixe = False If iNbChamps >= 1 Then sMot = asChamps(0).Trim If iNbChamps >= 2 Then sDef = asChamps(1).Trim clsMotExistant.ParserDefinition(sDef, sDefSuffixe, sDefPrefixe) End If If iNbChamps >= 3 Then sPrefixe = asChamps(2).Trim If iNbChamps >= 4 Then sSuffixe = asChamps(3).Trim If iNbChamps >= 5 Then sNivPrefixe = asChamps(4).Trim If iNbChamps >= 6 Then sNivSuffixe = asChamps(5).Trim If iNbChamps >= 7 Then sUnicitePrefixe = asChamps(6).Trim If iNbChamps >= 8 Then sUniciteSuffixe = asChamps(7).Trim If iNbChamps >= 9 Then sFreqPrefixe = asChamps(8).Trim If iNbChamps >= 10 Then sFreqSuffixe = asChamps(9).Trim ' 28/04/2019 If bElision AndAlso sPrefixe.EndsWith(sCarElisionO) Then bElisionPrefixe = True sPrefixe = sPrefixe.Replace(sCarElisionO, sCarO) End If 'If sSuffixe.EndsWith(sCarO) Then ' bElisionSuffixe = True 'End If If sNivPrefixe = "" OrElse sNivSuffixe = "" Then If bDebug Then Stop Continue For End If If Not m_dicoMotsExistants.ContainsKey(sMot) Then m_dicoMotsExistants.Add(sMot, New clsMotExistant(sMot, sDef, sPrefixe, sSuffixe, sDefPrefixe, sDefSuffixe, sNivPrefixe, sNivSuffixe, sUnicitePrefixe, sUniciteSuffixe, iNumMot, sFreqPrefixe, sFreqSuffixe, bElisionPrefixe)) iNumMot += 1 End If Next If bFiltrer Then Dim sCheminFiltre$ = Application.StartupPath & "\MotsSimplesSelect.csv" If Not bEcrireFichier(sCheminFiltre, sb) Then Exit Sub End If End Sub Public Function bLireMot(lstMots As List(Of String), iNumMot%, ByRef mot As clsMotExistant) As Boolean mot = New clsMotExistant() mot.iNumMotExistant = iNumMot Dim iNumSegment% = iNumMot * clsMotExistant.iNbColonnesME mot.sMot = lstMots(iNumSegment + clsMotExistant.iColMot) If bDebug AndAlso (mot.sMot Is Nothing) Then Stop mot.sDef = lstMots(iNumSegment + clsMotExistant.iColDef) If bDebug AndAlso (mot.sDef Is Nothing) Then Stop mot.sPrefixe = lstMots(iNumSegment + clsMotExistant.iColPrefixe) If bDebug AndAlso (mot.sPrefixe Is Nothing) Then Stop ' 28/04/2019 mot.bElisionPrefixe = False If bElision AndAlso mot.sPrefixe.EndsWith(sCarElisionO) Then mot.bElisionPrefixe = True mot.sPrefixe = mot.sPrefixe.Replace(sCarElisionO, sCarO) End If mot.sSuffixe = lstMots(iNumSegment + clsMotExistant.iColSuffixe) If bDebug AndAlso (mot.sSuffixe Is Nothing) Then Stop mot.sNivPrefixe = lstMots(iNumSegment + clsMotExistant.iColNivPrefixe) If bDebug AndAlso (mot.sNivPrefixe Is Nothing) Then Stop mot.iNivPrefixe = Integer.Parse(mot.sNivPrefixe) mot.sNivSuffixe = lstMots(iNumSegment + clsMotExistant.iColNivSuffixe) If bDebug AndAlso (mot.sNivSuffixe Is Nothing) Then Stop mot.iNivSuffixe = Integer.Parse(mot.sNivSuffixe) mot.sUnicitePrefixe = lstMots(iNumSegment + clsMotExistant.iColUnicitePrefixe) If bDebug AndAlso (mot.sUnicitePrefixe Is Nothing) Then Stop mot.sUniciteSuffixe = lstMots(iNumSegment + clsMotExistant.iColUniciteSuffixe) If bDebug AndAlso (mot.sUniciteSuffixe Is Nothing) Then Stop mot.sFreqPrefixe = lstMots(iNumSegment + clsMotExistant.iColFreqPrefixe) If bDebug AndAlso (mot.sFreqPrefixe Is Nothing) Then Stop mot.sFreqSuffixe = lstMots(iNumSegment + clsMotExistant.iColFreqSuffixe) If bDebug AndAlso (mot.sFreqSuffixe Is Nothing) Then Stop mot.ParserDefinition() mot.Synthese() Return True End Function Public Function iNbPrefixesMotsExistants%( lstNiv As List(Of String), lstFreq As List(Of String)) ' Compter tous les préfixes distincts des mots ' du ou des niveaux demandé(s) ' de la ou des fréquence(s) demandée(s) Dim enreg = (From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Select mot0.Value.sUnicitePrefixeSynth).Distinct Dim iNbEnreg% = enreg.Count Return iNbEnreg End Function Public Function lstPrefixesMotsExistants( lstNiv As List(Of String), lstFreq As List(Of String)) As List(Of clsMotExistant) ' Lister tous les préfixes des mots de niveau inférieur ou égal au niveau demandé ' (sans les mots dont les niveaux du préfixe et suffixe sont inférieurs) Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Dim lst As New List(Of clsMotExistant) Dim hs As New HashSet(Of String) For Each mot In enreg Dim sCle$ = mot.Value.sUnicitePrefixeSynth ' Ignorer les mots ayant la même racine (via l'unicité) If hs.Contains(sCle) Then Continue For hs.Add(sCle) lst.Add(mot.Value) Next Return lst End Function Public Function iNbSuffixesMotsExistants%( lstNiv As List(Of String), lstFreq As List(Of String)) ' Compter tous les suffixes distincts des mots de niveau inférieur ou égal au niveau demandé ' (sans les mots dont les niveaux du préfixe et suffixe sont inférieurs) Dim enreg = (From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Select mot0.Value.sUniciteSuffixeSynth).Distinct Dim iNbEnreg% = enreg.Count Return iNbEnreg End Function Public Function lstSuffixesMotsExistants( lstNiv As List(Of String), lstFreq As List(Of String)) As List(Of clsMotExistant) ' Lister tous les suffixes des mots de niveau inférieur ou égal au niveau demandé ' (sans les mots dont les niveaux du préfixe et suffixe sont inférieurs) Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Dim lst As New List(Of clsMotExistant) Dim hs As New HashSet(Of String) For Each mot In enreg Dim sCle$ = mot.Value.sUniciteSuffixeSynth ' Ignorer les mots ayant la même racine (via l'unicité) If hs.Contains(sCle) Then Continue For hs.Add(sCle) lst.Add(mot.Value) Next Return lst End Function Public Function iNbMotsExistants%( lstNiv As List(Of String), lstFreq As List(Of String)) ' Compter tous les mots du niveau demandé ' Note : en VB. Net, le regroupement sur des clés multiples exige ' le mot clé Key, sinon, ça ne marche pas Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Group mot0 By regroupement = New With { Key mot0.Value.sUnicitePrefixeSynth, Key mot0.Value.sUniciteSuffixeSynth } Into Group Select New With { regroupement.sUnicitePrefixeSynth, regroupement.sUniciteSuffixeSynth } Dim iNbEnreg% = enreg.Count Return iNbEnreg End Function Public Function iNbMotsExistantsTotal%( lstNiv As List(Of String), lstFreq As List(Of String)) ' Compter tous les mots du niveau demandé Dim enreg = From mot0 In m_dicoMotsExistants Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Dim iNbEnreg% = enreg.Count Return iNbEnreg End Function Public Function lstMotsExistants( lstNiv As List(Of String), lstFreq As List(Of String)) As List(Of clsMotExistant) ' Lister tous les mots du niveau demandé Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Dim lst As New List(Of clsMotExistant) Dim hs As New HashSet(Of String) For Each mot In enreg Dim sCle$ = mot.Value.sUnicitePrefixeSynth & ":" & mot.Value.sUniciteSuffixeSynth ' Ignorer les mots ayant la même racine (via l'unicité) If hs.Contains(sCle) Then Continue For hs.Add(sCle) lst.Add(mot.Value) Next Return lst End Function Public Function iTirageMotExistant%( lstNiv As List(Of String), lstFreq As List(Of String), ByRef prefixe As clsSegmentBase, ByRef suffixe As clsSegmentBase) ' Tirer au hasard un mot du niveau demandé ' 01/05/2019 Test élision : mot0.Value.bElisionPrefixe AndAlso Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) Dim iNbEnreg% = enreg.Count If iNbEnreg = 0 Then VBMessageBox("Aucun mot ne correspond à la sélection : Tirage impossible !") Return iTirageImpossible End If Dim iNbMotsExistantsFiltres% = iNbEnreg ' On tire un nombre compris entre 0 et iNbMotsExistantsFiltres - 1 (liste filtrée) Dim iNumMotExistantTire = iRandomiser(0, iNbMotsExistantsFiltres - 1) Dim mot = enreg(iNumMotExistantTire).Value If IsNothing(mot) Then If bDebug Then Stop Return iTirageImpossible End If ' Indice du mot dans la liste complète Dim iNumMotExistant% = mot.iNumMotExistant If iNumMotExistant = 0 Then If bDebug Then Stop Return iTirageImpossible End If prefixe = New clsSegmentBase suffixe = New clsSegmentBase prefixe.sSegment = mot.sPrefixe prefixe.sLogotron = sSelectDictionnaire prefixe.sNiveau = mot.sNivPrefixe prefixe.sSens = mot.sDefPrefixe prefixe.sEtym = "" prefixe.sUnicite = mot.sUnicitePrefixe prefixe.sUniciteSynth = mot.sUnicitePrefixeSynth prefixe.sFrequence = mot.sFreqPrefixe ' 28/04/2019 prefixe.bElision = mot.bElisionPrefixe prefixe.sSegmentElision = prefixe.sSegment If prefixe.bElision Then _ prefixe.sSegmentElision = prefixe.sSegment.Substring(0, prefixe.sSegment.Length - 1) suffixe.sSegment = mot.sSuffixe suffixe.sLogotron = sSelectDictionnaire suffixe.sNiveau = mot.sNivSuffixe suffixe.sSens = mot.sDefSuffixe suffixe.sEtym = "" suffixe.sUnicite = mot.sUniciteSuffixe suffixe.sUniciteSynth = mot.sUniciteSuffixeSynth suffixe.sFrequence = mot.sFreqSuffixe Return iNumMotExistant End Function Public Function iTirageMotExistantAutre%( lstNiv As List(Of String), lstFreq As List(Of String), iNumMotExistant%, itPrefixe As clsInitTirage, itSuffixe As clsInitTirage, lstNumMotExistant As List(Of Integer), ByRef motAutre As clsMotExistant) ' Tirer au hasard un autre mot du niveau demandé motAutre = Nothing Dim enreg = From mot0 In m_dicoMotsExistants.ToList() Where lstNiv.Contains(mot0.Value.sNivPrefixe) AndAlso lstNiv.Contains(mot0.Value.sNivSuffixe) AndAlso lstFreq.Contains(mot0.Value.sFreqPrefixe) AndAlso lstFreq.Contains(mot0.Value.sFreqSuffixe) AndAlso Not lstNumMotExistant.Contains(iNumMotExistant) AndAlso Not itPrefixe.lstSegmentsDejaTires.Contains(mot0.Value.sPrefixe) AndAlso Not itSuffixe.lstSegmentsDejaTires.Contains(mot0.Value.sSuffixe) AndAlso Not itPrefixe.lstSensSegmentDejaTires.Contains(mot0.Value.sDefPrefixe) AndAlso Not itSuffixe.lstSensSegmentDejaTires.Contains(mot0.Value.sDefSuffixe) AndAlso Not itPrefixe.lstUnicitesSegmentDejaTires.Contains(mot0.Value.sUnicitePrefixeSynth) AndAlso Not itSuffixe.lstUnicitesSegmentDejaTires.Contains(mot0.Value.sUniciteSuffixeSynth) Dim iNbEnreg% = enreg.Count If iNbEnreg = 0 Then VBMessageBox("Aucun mot ne correspond à la sélection : Tirage impossible !") Return iTirageImpossible End If Dim iNbMotsExistantsFiltres% = iNbEnreg ' On tire un nombre compris entre 0 et iNbMotsExistantsFiltres - 1 (liste filtrée) Dim iNumMotExistantTire = iRandomiser(0, iNbMotsExistantsFiltres - 1) motAutre = enreg(iNumMotExistantTire).Value If IsNothing(motAutre) Then If bDebug Then Stop Return iTirageImpossible End If ' Indice du mot dans la liste complète Dim iNumMotExistantAutre% = motAutre.iNumMotExistant Const bDebugTirage As Boolean = False If bDebugTirage Then Dim mot = m_dicoMotsExistants.Values(iNumMotExistant) Debug.WriteLine("Mot choisi : " & mot.ToString) Debug.WriteLine("Mot autre : " & motAutre.ToString) Dim iNum% = 0 For Each iNumMotE In lstNumMotExistant iNum += 1 Dim motE = m_dicoMotsExistants.Values(iNumMotE) Debug.WriteLine("Mot autre n° " & iNum & " : " & motE.ToString) Next End If lstNumMotExistant.Add(iNumMotExistantAutre) itPrefixe.lstSegmentsDejaTires.Add(motAutre.sPrefixe) itSuffixe.lstSegmentsDejaTires.Add(motAutre.sSuffixe) itPrefixe.lstSensSegmentDejaTires.Add(motAutre.sDefPrefixe) itSuffixe.lstSensSegmentDejaTires.Add(motAutre.sDefSuffixe) itPrefixe.lstUnicitesSegmentDejaTires.Add(motAutre.sUnicitePrefixeSynth) itSuffixe.lstUnicitesSegmentDejaTires.Add(motAutre.sUniciteSuffixeSynth) Return iNumMotExistant End Function #End Region Public Sub InitBases() m_prefixes = New clsBase(iNbColonnes, bPrefixe:=True) m_suffixes = New clsBase(iNbColonnes, bPrefixe:=False) m_defFls = New clsDefExclusives End Sub #Region "Utile" Public Function bTrouverSegment(sSegment$, bSuffixe As Boolean, ByRef iNumSegmentTrouve%) _ As Boolean ' Trouver le segment demandé If bSuffixe Then Return m_suffixes.bTrouverSegment(sSegment, iNumSegmentTrouve) Else Return m_prefixes.bTrouverSegment(sSegment, iNumSegmentTrouve) End If End Function Public Function sCompleterPrefixe$(sSensPrefixeOrig$) ' Correction de L', LE et LES en DE L', DU et DES ' Ex.: L'AIR -> DE L'AIR, LE MÉTAL -> DU MÉTAL, LES IDÉES -> DES IDÉES If String.IsNullOrEmpty(sSensPrefixeOrig) Then Return "" If sLang <> enumLangue.Fr Then Return sSensPrefixeOrig Dim sSensPrefixe$ = sSensPrefixeOrig Dim iLongSensPrefixe% = sSensPrefixeOrig.Length If iLongSensPrefixe = 0 Then Return sSensPrefixe If sSensPrefixeOrig.Substring(0, 3) = "LE " Then sSensPrefixe = "DU " & sSensPrefixeOrig.Substring(3) ElseIf iLongSensPrefixe >= 4 AndAlso sSensPrefixeOrig.Substring(0, 4) = "LES " Then sSensPrefixe = "DES " & sSensPrefixeOrig.Substring(4) ElseIf sSensPrefixeOrig.Substring(0, 3) = "LA " OrElse sSensPrefixeOrig.Substring(0, 2) = "L'" Then sSensPrefixe = "DE " + sSensPrefixeOrig End If ' En cas de sens multiple, ex. : "histo" -> "la trame / le tissu" -> "de trame / du tissu" 'Dim sSensPrefixe2 = sSensPrefixe. _ ' Replace("/ LE", "/ DU"). _ ' Replace("/ LES", "/ DES"). _ ' Replace("/ LA ", "/ DE "). _ ' Replace("/ L'", "/ DE ") Dim sSensPrefixe2 = sRemplacerCar(sSensPrefixe, "/") Dim sSensPrefixe3 = sRemplacerCar(sSensPrefixe2, "->") Return sSensPrefixe3 End Function Private Function sRemplacerCar$(sTxt$, sCar$) If sLang <> enumLangue.Fr Then Return sTxt ' LA MAISON -> L'ÉCOLOGIE / L'ÉCONOMIE ' -> ' DE LA MAISON -> DE L'ÉCOLOGIE / DE L'ÉCONOMIE Dim sTxtCorr = sTxt. Replace(sCar & " LE ", sCar & " DU "). Replace(sCar & " LES ", sCar & " DES "). Replace(sCar & " LA ", sCar & " DE LA "). Replace(sCar & " L'É", sCar & " DE L'É"). Replace(sCar & " L'", sCar & " DE L'") Return sTxtCorr End Function Public Function sSupprimerArticle$(sTxt$) ' Supprimer le, la, l' If sLang <> enumLangue.Fr Then Return sTxt Dim sTxtCorr1 = sSupprimerArticleInterm("les", sTxt) Dim sTxtCorr2 = sSupprimerArticleInterm("le", sTxtCorr1) Dim sTxtCorr3 = sSupprimerArticleInterm("la", sTxtCorr2) 'Dim sTxtCorr4 = sSupprimerArticleInterm("l'", sTxtCorr3) Dim sTxtCorr4 = sTxtCorr3.Replace("l'", "") Return sTxtCorr4 End Function Private Function sSupprimerArticleInterm$(sArticle$, sTxt$) Dim sTxtCorr1 = sTxt.Replace("/ " & sArticle, "/") Dim sTxtCorr2 = sTxtCorr1.Replace("-> " & sArticle, "->") Dim sTxtCorr3 = sTxtCorr2.Replace("," & sArticle, ",") ' 07/10/2018 En dernier If sTxtCorr3.StartsWith(sArticle & " ") Then Dim iLongArticle = sArticle.Length Dim sSubs$ = sTxtCorr3.Substring(iLongArticle + 1, sTxtCorr3.Length - iLongArticle - 1) Return sSubs End If Return sTxtCorr3 End Function #End Region Public Class clsInitTirage Public lstNumSegmentDejaTires As New List(Of Integer) Public lstSegmentsDejaTires As New List(Of String) Public lstSensSegmentDejaTires As New List(Of String) Public lstUnicitesSegmentDejaTires As New List(Of String) Public Sub New() End Sub Public Sub New(segment As clsSegmentBase) If segment Is Nothing Then Throw New ArgumentNullException("segment") lstNumSegmentDejaTires.Add(segment.iNumSegment) lstSegmentsDejaTires.Add(segment.sSegment) lstSensSegmentDejaTires.Add(segment.sSens) If segment.sUnicite.Length > 0 Then _ lstUnicitesSegmentDejaTires.Add(segment.sUnicite) End Sub End Class Public Class clsSegmentBase Public sSegment$, sSens$, sLogotron$, sNiveau$, sEtym$, sUnicite$ Public sUniciteSynth$ Public sOrigine$ ' Origine étymologique : Latin, Grec, ... Public sFrequence$ ' Fréquence du segment dans la liste des mots existants (seulement les complets) Public iNiveau%, iNumSegment% Public bElision As Boolean, sSegmentElision$ Public Function sAfficher$(bPrefixe As Boolean) Dim sTxt$ = "" If bPrefixe Then sTxt = Me.sSegment & "-" Else sTxt = "-" & Me.sSegment End If Dim sTxtComplement = sTxt & "(" & Me.sNiveau & ") : " & Me.sSens & ", origine : " & Me.sOrigine & ", fréquence : " & Me.sFrequence Return sTxtComplement End Function End Class Public Class clsBase Private m_iNbColonnes% = 0 Private Const iColSegment% = 0 Private Const iColPrefixe% = 0 Private Const iColSuffixe% = 0 Private Const iColSens% = 1 Private Const iColLogotron% = 2 Private Const iColNiveau% = 3 Private Const iColEtym% = 4 Private Const iColUnicite% = 5 Private Const iColOrigine% = 6 Private Const iColFrequence% = 7 Private m_lstSegments As List(Of String) Private m_bPrefixe As Boolean Public Sub New(iNbColonnes%, bPrefixe As Boolean) m_lstSegments = New List(Of String) m_iNbColonnes = iNbColonnes m_bPrefixe = bPrefixe ' 01/05/2019 End Sub Public Function iLireNbSegments%() If m_iNbColonnes = 0 Then If bDebug Then Stop Return 0 End If Dim iNbSegments% = m_lstSegments.Count / m_iNbColonnes Return iNbSegments End Function Public Function iLireNbSegmentsUniques%( lstNiveaux As List(Of String), lstFreq As List(Of String), bGrecoLatin As Boolean, bNeoRigolo As Boolean) ' Retourner la liste de segments uniques selon le sens, avec les niveaux indiqués ' (sélection du Logotron) If lstNiveaux Is Nothing Then Throw New ArgumentNullException("lstNiveaux") Dim hsSegments As New HashSet(Of String) Dim iNbSegments% = iLireNbSegments() For i As Integer = 0 To iNbSegments - 1 Dim segment As clsSegmentBase = Nothing If Not bLireSegment(i, segment) Then Continue For If Not lstNiveaux.Contains(segment.sNiveau) Then Continue For If Not IsNothing(lstFreq) AndAlso Not lstFreq.Contains(segment.sFrequence) Then Continue For If segment.sLogotron <> sSelectLogotron Then Continue For If (bGrecoLatin OrElse Not bNeoRigolo) AndAlso segment.sOrigine = enumOrigine.sNeologismeAmusant Then 'Debug.WriteLine("Segment non retenu : " & segment.sSegment & " : " & _ ' segment.sOrigine) Continue For End If If bGrecoLatin AndAlso Not (segment.sOrigine = enumOrigine.sGrec OrElse segment.sOrigine = enumOrigine.sLatin OrElse segment.sOrigine = enumOrigine.sGrecoLatin) Then 'Debug.WriteLine("Segment non gréco-latin : " & segment.sSegment & " : " & _ ' segment.sOrigine) Continue For End If Dim sSensSansArticle$ = sSupprimerArticle(segment.sSens) Dim sCleUniciteSens$ = sSensSansArticle If segment.sUnicite.Length > 0 Then sCleUniciteSens = segment.sUnicite If Not hsSegments.Contains(sCleUniciteSens) Then hsSegments.Add(sCleUniciteSens) Next Return hsSegments.Count End Function Public Function iTirageSegment%(bComplet As Boolean, lstNiveaux As List(Of String), lstFreq As List(Of String), bGrecoLatin As Boolean, bNeoRigolo As Boolean) Return iTirageSegment(bComplet, lstNiveaux, lstFreq, New clsInitTirage, bGrecoLatin, bNeoRigolo) End Function Public Function iTirageSegment%(bComplet As Boolean, lstNiv As List(Of String), lstFreq As List(Of String), it As clsInitTirage, bGrecoLatin As Boolean, bNeoRigolo As Boolean) ' bComplet : tous les segments (y compris ceux du dictionnaire), ' ou sinon seulement ceux du Logotron ' lstNiveaux : combinaison des niveaux "1", "2" et/ou "3" ' lstNumSegmentDejaTires : ne pas tirer à nouveau un segment déjà tiré ' (pour avoir un mot avec plusieurs préfixes distincts) ' lstSegmentDejaTires : ne pas tirer à nouveau un segment déjà tiré ' (cette fois le segment doit être unique, dans le cas où des segments ' seraient présents avec plusieurs sens) ' lstSensSegmentDejaTires : ne pas tirer à nouveau un sens déjà tiré ' lstUnicitesSegmentDejaTires : lié au champ unicité ' (unicité explicite car le sens peut varier plus ou moins) ' bGrecoLatin : seulement les segments d'origine greco-latine, ' sinon les segments de toutes origines ' bNeoRigolo : inclure les néologismes amusants ' Il faut vérifier que le tirage est possible : compter qu'il y a ' au moins 1 candidat, sinon boucle infinie dans le tirage ' 01/05/2019 Test élision : '((m_bPrefixe AndAlso seg0.sSegment.EndsWith(sCarO)) OrElse ' (Not m_bPrefixe AndAlso seg0.sSegment.StartsWith(sCarO))) AndAlso Dim lst = ObtenirSegmentBases() Dim enreg = From seg0 In lst Where lstNiv.Contains(seg0.sNiveau) AndAlso lstFreq.Contains(seg0.sFrequence) AndAlso ((it.lstNumSegmentDejaTires Is Nothing) OrElse Not it.lstNumSegmentDejaTires.Contains(seg0.iNumSegment)) AndAlso ((it.lstSegmentsDejaTires Is Nothing) OrElse Not it.lstSegmentsDejaTires.Contains(seg0.sSegment)) AndAlso ((it.lstSensSegmentDejaTires Is Nothing) OrElse Not it.lstSensSegmentDejaTires.Contains(seg0.sSens)) AndAlso ((it.lstUnicitesSegmentDejaTires Is Nothing) OrElse Not it.lstUnicitesSegmentDejaTires.Contains(seg0.sUnicite)) AndAlso (bComplet OrElse seg0.sLogotron = sSelectLogotron) AndAlso ((Not bGrecoLatin AndAlso (bNeoRigolo OrElse seg0.sOrigine <> enumOrigine.sNeologismeAmusant)) OrElse (bGrecoLatin AndAlso (seg0.sOrigine = enumOrigine.sGrec OrElse seg0.sOrigine = enumOrigine.sLatin OrElse seg0.sOrigine = enumOrigine.sGrecoLatin))) Dim iNbEnreg% = enreg.Count If iNbEnreg = 0 Then VBMessageBox("Aucun élément ne correspond à la sélection : Tirage impossible !") Return iTirageImpossible End If Dim iNbSegmentsFilres% = iNbEnreg ' On tire un nombre compris entre 0 et iNbSegmentsFilres - 1 (liste filtrée) Dim iNumSegment2 = iRandomiser(0, iNbSegmentsFilres - 1) Dim seg = enreg(iNumSegment2) Dim iNumSegment = seg.iNumSegment ' Indice du segment dans la liste complète If (it.lstNumSegmentDejaTires IsNot Nothing) Then it.lstNumSegmentDejaTires.Add(iNumSegment) If (it.lstSegmentsDejaTires IsNot Nothing) Then it.lstSegmentsDejaTires.Add(seg.sSegment) If (it.lstSensSegmentDejaTires IsNot Nothing) Then it.lstSensSegmentDejaTires.Add(seg.sSens) If seg.sUnicite.Length > 0 AndAlso (it.lstUnicitesSegmentDejaTires IsNot Nothing) Then _ it.lstUnicitesSegmentDejaTires.Add(seg.sUnicite) Return iNumSegment End Function Public Function sTrouverEtymologie$(sSegment$, sUniciteSynth$) Dim enreg = From seg0 In ObtenirSegmentBases() Where seg0.sSegment = sSegment AndAlso seg0.sUniciteSynth = sUniciteSynth Dim iNbEnreg% = enreg.Count If iNbEnreg = 0 Then Return "" Dim sEtym$ = "" For Each enr In enreg sEtym = enr.sEtym Exit For Next Return sEtym End Function Public Function lstSegmentsAutreOrigine( lstNiv As List(Of String), lstFreq As List(Of String), bNeoRigolo As Boolean) As List(Of clsSegmentBase) ' Lister tous les segments avec une autre origine, ' pour le niveau demandé et la fréquence demandée Dim enreg = From seg0 In ObtenirSegmentBases() Where lstNiv.Contains(seg0.sNiveau) AndAlso lstFreq.Contains(seg0.sFrequence) AndAlso (bNeoRigolo OrElse seg0.sOrigine <> enumOrigine.sNeologismeAmusant) AndAlso (Not _ (seg0.sOrigine = enumOrigine.sGrec OrElse seg0.sOrigine = enumOrigine.sLatin OrElse seg0.sOrigine = enumOrigine.sGrecoLatin)) Dim lst = enreg.ToList() Return lst End Function Public Sub DefinirSegments(segments As List(Of String), iNbColonnes%) m_lstSegments = segments m_iNbColonnes = iNbColonnes End Sub Public Function ObtenirSegments() As List(Of String) Return m_lstSegments End Function Public Function ObtenirSegmentBases() As List(Of clsSegmentBase) Dim lst As New List(Of clsSegmentBase) For i As Integer = 0 To iLireNbSegments() - 1 Dim segment As clsSegmentBase = Nothing If bLireSegment(i, segment) Then lst.Add(segment) Next Return lst End Function Public Sub AjouterSegment(segment As clsSegmentBase) If segment Is Nothing Then Throw New ArgumentNullException("segment") m_lstSegments.Add(segment.sSegment) m_lstSegments.Add(segment.sSens) m_lstSegments.Add(segment.sLogotron) m_lstSegments.Add(segment.sNiveau) m_lstSegments.Add(segment.sEtym) m_lstSegments.Add(segment.sUnicite) m_lstSegments.Add(segment.sOrigine) m_lstSegments.Add(segment.sFrequence) End Sub Public Function bLireSegment(iNumSegmentL%, ByRef segment As clsSegmentBase) As Boolean segment = Nothing If m_iNbColonnes <= 0 Then Return False : If bDebug Then Stop If iNumSegmentL = iTirageImpossible Then Return False segment = New clsSegmentBase segment.iNumSegment = iNumSegmentL Dim iNumSegment% = iNumSegmentL * m_iNbColonnes segment.sSegment = m_lstSegments(iNumSegment + iColPrefixe) If bDebug AndAlso (segment.sSegment Is Nothing) Then Stop If m_iNbColonnes <= iColSens Then Return True segment.sSens = m_lstSegments(iNumSegment + iColSens) If bDebug AndAlso (segment.sSens Is Nothing) Then Stop If m_iNbColonnes <= iColLogotron Then Return True segment.sLogotron = m_lstSegments(iNumSegment + iColLogotron) If bDebug AndAlso (segment.sLogotron Is Nothing) Then Stop If m_iNbColonnes <= iColNiveau Then Return True segment.sNiveau = m_lstSegments(iNumSegment + iColNiveau) If bDebug AndAlso (segment.sNiveau Is Nothing) Then Stop segment.iNiveau = Integer.Parse(segment.sNiveau) If m_iNbColonnes <= iColEtym Then Return True segment.sEtym = m_lstSegments(iNumSegment + iColEtym) If bDebug AndAlso (segment.sEtym Is Nothing) Then Stop If m_iNbColonnes <= iColUnicite Then Return True segment.sUnicite = m_lstSegments(iNumSegment + iColUnicite) If bDebug AndAlso (segment.sUnicite Is Nothing) Then Stop If m_iNbColonnes <= iColOrigine Then Return True segment.sOrigine = m_lstSegments(iNumSegment + iColOrigine) If bDebug AndAlso (segment.sOrigine Is Nothing) Then Stop If m_iNbColonnes <= iColFrequence Then Return True segment.sFrequence = m_lstSegments(iNumSegment + iColFrequence) If bDebug AndAlso (segment.sFrequence Is Nothing) Then Stop Dim sSensSansArticle$ = sSupprimerArticle(segment.sSens) Dim sUniciteFinale$ = sSensSansArticle segment.sUniciteSynth = sUniciteFinale If segment.sUnicite.Length > 0 Then segment.sUniciteSynth = segment.sUnicite If m_iNbColonnes <= iNbColonnes Then Return True Return True End Function Public Function bTrouverSegment(sSegment$, ByRef iNumSegmentTrouve%) As Boolean ' Trouver le segment demandé Dim enreg = From seg0 In ObtenirSegmentBases() Where seg0.sSegment = sSegment Select seg0.iNumSegment Dim lst = enreg.ToList() For Each iNumSeg In lst iNumSegmentTrouve = iNumSeg Return True Next iNumSegmentTrouve = -1 Return False End Function End Class End Module clsDefExclusives.vb Public Class clsDefExclusives Private m_dicoDefExcl As Dictionary(Of String, String) ' Clé : sMot -> sSens exclusif Private m_dicoDefSegExcl As Dictionary(Of String, String) ' Clé : sSegment -> sSens exclusif Public Sub New() m_dicoDefExcl = New Dictionary(Of String, String) m_dicoDefSegExcl = New Dictionary(Of String, String) End Sub Public Sub AjouterListe(bPrefixe As Boolean, sSegment$, sSens$, sListeMotsExcl$) Dim asChamps2() = sListeMotsExcl.Split(",") Dim iNbChamps2% = asChamps2.GetUpperBound(0) + 1 Dim sCle$ = "-" & sSegment If bPrefixe Then sCle = sSegment & "-" If Not m_dicoDefSegExcl.ContainsKey(sCle) Then m_dicoDefSegExcl.Add(sCle, sSens) For i As Integer = 0 To iNbChamps2 - 1 Dim sMotExcl$ = asChamps2(i).Trim ' 12/07/2020 Dim iNumPrefixe% = 1 If sMotExcl.Contains(":") Then Dim asChps$() = sMotExcl.Split(":") sMotExcl = asChps(0) Dim sNumPrefixe$ = asChps(1).Trim iNumPrefixe = CInt(sNumPrefixe) Dim iNumPrefixe0% = 0 If Integer.TryParse(sNumPrefixe, iNumPrefixe0) Then _ iNumPrefixe = iNumPrefixe0 End If Dim sType$ = "S:" If bPrefixe Then sType = "P:" If iNumPrefixe > 1 Then sType = "P" & iNumPrefixe & ":" ' 12/07/2020 End If Dim sCleMot$ = sType & sMotExcl If Not m_dicoDefExcl.ContainsKey(sCleMot) Then m_dicoDefExcl.Add(sCleMot, sSens) End If Next End Sub Public Function bSensExclusifAutre(sCleExcl$, sMotDico$, sSensSeg$, bPrefixe As Boolean, Optional iNumPrefixe% = 1) As Boolean Dim sType$ = "S:" If bPrefixe Then sType = "P:" If iNumPrefixe > 1 Then sType = "P" & iNumPrefixe & ":" ' 12/07/2020 End If Dim sCleMot$ = sType & sMotDico ' 05/01/2018 If m_dicoDefSegExcl.ContainsKey(sCleExcl) Then ' Le segment contient un sens spécifique à certains mots Dim sSensExclSeg$ = m_dicoDefSegExcl(sCleExcl) If Not m_dicoDefExcl.ContainsKey(sCleMot) Then ' Ce mot ne fait pas partie des exclusivités If sSensExclSeg = sSensSeg Then ' Donc le sens exclusif doit être ignoré 'Debug.WriteLine("Exclusion : " & sMotDico & " : " & sSensSeg) Return True End If ' Sens général : on accepte Else ' Ce mot fait partie des exclusivités Dim sSensExcl$ = m_dicoDefExcl(sCleMot) If sSensExcl <> sSensSeg Then ' Sens général : on ignore 'Debug.WriteLine("Exclusion : " & ' sMotDico & " : " & sSensSeg & " <> " & sSensExclMot) Return True End If ' Sens exclusif pour un mot en exclusivité : on accepte End If End If Return False End Function End Class modListeMotsExistants.vb Module ModListeMotsExistants Public Sub ChargerMotsExistantsCode(ByRef dicoMotsExistants As Dictionary(Of String, clsMotExistant)) dicoMotsExistants = New Dictionary(Of String, clsMotExistant) ' Cette liste peut être récupérée via DicoLogotron\Doc\MotsSimplesCode_fr.txt #If DEBUG Then ' Liste incomplète ici, simple test Dim lstMots As New List(Of String) From { "abiotique", "VIE SANS", "a", "biotique", "1", "1", "a", "bio", "Frequent", "Moyen", "acalorique", "CHALEUR SANS", "a", "calorique", "1", "2", "a", "calori", "Frequent", "Moyen", "acanthocéphale", "TÊTE DE L'ÉPINE", "acantho", "céphale", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthocyte", "CELLULE DE L'ÉPINE", "acantho", "cyte", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthodactyle", "DOIGT DE L'ÉPINE", "acantho", "dactyle", "3", "2", "acantho", "dactylo", "Moyen", "Frequent", "acanthoglosse", "LANGUE DE L'ÉPINE", "acantho", "glosse", "3", "3", "acantho", "glosso", "Moyen", "Moyen", "acantholyse", "DÉCOMPOSITION DE L'ÉPINE", "acantho", "lyse", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthomètre", "MESUREUR DE L'ÉPINE", "acantho", "mètre", "3", "1", "acantho", "métro (métron)", "Moyen", "Frequent", "acanthozoïde", "ANIMAL DE L'ÉPINE", "acantho", "zoïde", "3", "1", "acantho", "", "Moyen", "Moyen", "acarpe", "POIGNET SANS", "a", "carpe", "1", "3", "a", "", "Frequent", "Moyen", "acentrique", "CENTRÉ SANS", "a", "centrique", "1", "1", "a", "centro", "Frequent", "Frequent", "acéphale", "TÊTE SANS", "a", "céphale", "1", "2", "a", "", "Frequent", "Frequent", "acéphalie", "TÊTE SANS", "a", "céphalie", "1", "2", "a", "", "Frequent", "Frequent", "acère", "CORNE SANS", "a", "cère", "1", "3", "a", "cérato", "Frequent", "Moyen", "achrome", "COULEUR SANS", "a", "chrome", "1", "1", "a", "chromo", "Frequent", "Frequent", "achromie", "COULEUR SANS", "a", "chromie", "1", "1", "a", "chromo", "Frequent", "Frequent", "achronique", "TEMPOREL(LE) SANS", "a", "chronique", "1", "1", "a", "chrono", "Frequent", "Moyen", "acide", "QUI TUE SANS", "a", "cide", "1", "1", "a", "", "Frequent", "Frequent", "acinèse", "MOUVEMENT SANS", "a", "cinèse", "1", "2", "a", "cinèse", "Frequent", "Moyen", "acinésie", "MOUVEMENT SANS", "a", "cinésie", "1", "2", "a", "cinèse", "Frequent", "Moyen", "acosmique", "UNIVERSALITÉ SANS", "a", "cosmique", "1", "1", "a", "cosmo", "Frequent", "Rare", "acoumètre", "MESUREUR DE L'AUDITION", "acou", "mètre", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acoumétrie", "MESURE DE L'AUDITION", "acou", "métrie", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acoumétrique", "MESURAGE DE L'AUDITION", "acou", "métrique", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acouphène", "APPARITION DE L'AUDITION", "acou", "phène", "2", "3", "", "", "Moyen", "Moyen", "acrocarpe", "POIGNET ÉLEVÉ(E) / EXTRÊME", "acro", "carpe", "3", "3", "", "", "Frequent", "Moyen", "acrocentrique", "CENTRÉ ÉLEVÉ(E) / EXTRÊME", "acro", "centrique", "3", "1", "", "centro", "Frequent", "Frequent", "acrocéphale", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphale", "3", "2", "", "", "Frequent", "Frequent", "acrocéphalie", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphalie", "3", "2", "", "", "Frequent", "Frequent", "acrocéphalique", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphalique", "3", "2", "", "", "Frequent", "Rare", "acrodonte", "DENT ÉLEVÉ(E) / EXTRÊME", "acr(o)", "odonte", "3", "3", "", "", "Frequent", "Moyen", "acrodynie", "ÉNERGIE ÉLEVÉ(E) / EXTRÊME", "acro", "dynie", "3", "2", "", "dyne", "Frequent", "Moyen", "acroïde", "APPARENCE ÉLEVÉ(E) / EXTRÊME", "acro", "ïde", "3", "3", "", "", "Frequent", "Frequent", "acrolithe", "PIERRE ÉLEVÉ(E) / EXTRÊME", "acro", "lithe", "3", "2", "", "litho", "Frequent", "Frequent", "acromégalie", "GRANDEUR ÉLEVÉ(E) / EXTRÊME", "acro", "mégalie", "3", "1", "", "mégalo", "Frequent", "Moyen", "acronyme", "NOM ÉLEVÉ(E) / EXTRÊME", "acr(o)", "onyme", "3", "3", "", "", "Frequent", "Moyen", "acronymie", "NOM ÉLEVÉ(E) / EXTRÊME", "acro", "nymie", "3", "3", "", "", "Frequent", "Moyen", "acropathie", "MALADIE ÉLEVÉ(E) / EXTRÊME", "acro", "pathie", "3", "2", "", "patho (souffrance)", "Frequent", "Frequent", "acropète", "QUI VA VERS ÉLEVÉ(E) / EXTRÊME", "acro", "pète", "3", "2", "", "", "Frequent", "Rare", "acrophobie", "AVERSION ÉLEVÉ(E) / EXTRÊME", "acro", "phobie", "3", "1", "", "phobe", "Frequent", "Frequent", "acrophonie", "VOIX ÉLEVÉ(E) / EXTRÊME", "acro", "phonie", "3", "1", "", "", "Frequent", "Frequent", "acropode", "PIED ÉLEVÉ(E) / EXTRÊME", "acro", "pode", "3", "2", "", "", "Frequent", "Frequent", "acropole", "VILLE ÉLEVÉ(E) / EXTRÊME", "acro", "pole", "3", "2", "", "", "Frequent", "Moyen", "acrosome", "CORPS ÉLEVÉ(E) / EXTRÊME", "acro", "some", "3", "2", "", "somato", "Frequent", "Frequent", "actinifère", "PORTER DU RAYON", "actini", "fère", "3", "2", "", "", "Rare", "Frequent", "actinique", "À PROPOS DU RAYON", "actin", "ique", "3", "2", "", "", "Moyen", "Frequent", "actinisme", "DOCTRINE / ÉTAT / PROFESSION DU RAYON", "actin", "isme", "3", "2", "", "", "Moyen", "Frequent", "actinite", "INFLAMMATION DU RAYON", "actin", "ite", "3", "2", "", "", "Moyen", "Frequent", "actinologie", "ÉTUDE DU RAYON", "actino", "logie", "3", "1", "", "logo", "Moyen", "Frequent", "actinologique", "ÉTUDE DU RAYON", "actino", "logique", "3", "1", "", "logo", "Moyen", "Frequent", "actinomètre", "MESUREUR DU RAYON", "actino", "mètre", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinométrie", "MESURE DU RAYON", "actino", "métrie", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinométrique", "MESURAGE DU RAYON", "actino", "métrique", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinomorphe", "FORME DU RAYON", "actino", "morphe", "3", "1", "", "morpho", "Moyen", "Frequent", "actinomycète", "CHAMPIGNON DU RAYON", "actino", "mycète", "3", "2", "", "", "Moyen", "Moyen", "actinomycose", "CHAMPIGNON DU RAYON", "actino", "mycose", "3", "2", "", "", "Moyen", "Moyen", "actinopode", "PIED DU RAYON", "actino", "pode", "3", "2", "", "", "Moyen", "Frequent", "actinoscopie", "EXAMEN DU RAYON", "actino", "scopie", "3", "1", "", "scope", "Moyen", "Frequent", "actinothérapie", "MÉDECINE DU RAYON", "actino", "thérapie", "3", "1", "", "thérapie", "Moyen", "Frequent", "actinotropisme", "ATTIRANCE DU RAYON", "actino", "tropisme", "3", "2", "", "trope", "Moyen", "Frequent", "acyclique", "CIRCULARITÉ SANS", "a", "cyclique", "1", "1", "a", "cyclo", "Frequent", "Frequent" } #Else ' Liste complète (ne compile pas sous Visual Studio 2013) Dim lstMots As New List(Of String) From { "abiotique", "VIE SANS", "a", "biotique", "1", "1", "a", "bio", "Frequent", "Moyen", "acalorique", "CHALEUR SANS", "a", "calorique", "1", "2", "a", "calori", "Frequent", "Moyen", "acanthocéphale", "TÊTE DE L'ÉPINE", "acantho", "céphale", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthocyte", "CELLULE DE L'ÉPINE", "acantho", "cyte", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthodactyle", "DOIGT DE L'ÉPINE", "acantho", "dactyle", "3", "2", "acantho", "dactylo", "Moyen", "Frequent", "acanthoglosse", "LANGUE DE L'ÉPINE", "acantho", "glosse", "3", "3", "acantho", "glosso", "Moyen", "Moyen", "acantholyse", "DÉCOMPOSITION DE L'ÉPINE", "acantho", "lyse", "3", "2", "acantho", "", "Moyen", "Frequent", "acanthomètre", "MESUREUR DE L'ÉPINE", "acantho", "mètre", "3", "1", "acantho", "métro (métron)", "Moyen", "Frequent", "acanthozoïde", "ANIMAL DE L'ÉPINE", "acantho", "zoïde", "3", "1", "acantho", "", "Moyen", "Moyen", "acarpe", "POIGNET SANS", "a", "carpe", "1", "3", "a", "", "Frequent", "Moyen", "acentrique", "CENTRÉ SANS", "a", "centrique", "1", "1", "a", "centro", "Frequent", "Frequent", "acéphale", "TÊTE SANS", "a", "céphale", "1", "2", "a", "", "Frequent", "Frequent", "acéphalie", "TÊTE SANS", "a", "céphalie", "1", "2", "a", "", "Frequent", "Frequent", "acère", "CORNE SANS", "a", "cère", "1", "3", "a", "cérato", "Frequent", "Moyen", "achrome", "COULEUR SANS", "a", "chrome", "1", "1", "a", "chromo", "Frequent", "Frequent", "achromie", "COULEUR SANS", "a", "chromie", "1", "1", "a", "chromo", "Frequent", "Frequent", "achronique", "TEMPOREL(LE) SANS", "a", "chronique", "1", "1", "a", "chrono", "Frequent", "Moyen", "acide", "QUI TUE SANS", "a", "cide", "1", "1", "a", "", "Frequent", "Frequent", "acinèse", "MOUVEMENT SANS", "a", "cinèse", "1", "2", "a", "cinèse", "Frequent", "Moyen", "acinésie", "MOUVEMENT SANS", "a", "cinésie", "1", "2", "a", "cinèse", "Frequent", "Moyen", "acosmique", "UNIVERSALITÉ SANS", "a", "cosmique", "1", "1", "a", "cosmo", "Frequent", "Rare", "acoumètre", "MESUREUR DE L'AUDITION", "acou", "mètre", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acoumétrie", "MESURE DE L'AUDITION", "acou", "métrie", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acoumétrique", "MESURAGE DE L'AUDITION", "acou", "métrique", "2", "1", "", "métro (métron)", "Moyen", "Frequent", "acouphène", "APPARITION DE L'AUDITION", "acou", "phène", "2", "3", "", "", "Moyen", "Moyen", "acrocarpe", "POIGNET ÉLEVÉ(E) / EXTRÊME", "acro", "carpe", "3", "3", "", "", "Frequent", "Moyen", "acrocentrique", "CENTRÉ ÉLEVÉ(E) / EXTRÊME", "acro", "centrique", "3", "1", "", "centro", "Frequent", "Frequent", "acrocéphale", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphale", "3", "2", "", "", "Frequent", "Frequent", "acrocéphalie", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphalie", "3", "2", "", "", "Frequent", "Frequent", "acrocéphalique", "TÊTE ÉLEVÉ(E) / EXTRÊME", "acro", "céphalique", "3", "2", "", "", "Frequent", "Rare", "acrodonte", "DENT ÉLEVÉ(E) / EXTRÊME", "acr(o)", "odonte", "3", "3", "", "", "Frequent", "Moyen", "acrodynie", "ÉNERGIE ÉLEVÉ(E) / EXTRÊME", "acro", "dynie", "3", "2", "", "dyne", "Frequent", "Moyen", "acroïde", "APPARENCE ÉLEVÉ(E) / EXTRÊME", "acro", "ïde", "3", "3", "", "", "Frequent", "Frequent", "acrolithe", "PIERRE ÉLEVÉ(E) / EXTRÊME", "acro", "lithe", "3", "2", "", "litho", "Frequent", "Frequent", "acromégalie", "GRANDEUR ÉLEVÉ(E) / EXTRÊME", "acro", "mégalie", "3", "1", "", "mégalo", "Frequent", "Moyen", "acronyme", "NOM ÉLEVÉ(E) / EXTRÊME", "acr(o)", "onyme", "3", "3", "", "", "Frequent", "Moyen", "acronymie", "NOM ÉLEVÉ(E) / EXTRÊME", "acro", "nymie", "3", "3", "", "", "Frequent", "Moyen", "acropathie", "MALADIE ÉLEVÉ(E) / EXTRÊME", "acro", "pathie", "3", "2", "", "patho (souffrance)", "Frequent", "Frequent", "acropète", "QUI VA VERS ÉLEVÉ(E) / EXTRÊME", "acro", "pète", "3", "2", "", "", "Frequent", "Rare", "acrophobie", "AVERSION ÉLEVÉ(E) / EXTRÊME", "acro", "phobie", "3", "1", "", "phobe", "Frequent", "Frequent", "acrophonie", "VOIX ÉLEVÉ(E) / EXTRÊME", "acro", "phonie", "3", "1", "", "", "Frequent", "Frequent", "acropode", "PIED ÉLEVÉ(E) / EXTRÊME", "acro", "pode", "3", "2", "", "", "Frequent", "Frequent", "acropole", "VILLE ÉLEVÉ(E) / EXTRÊME", "acro", "pole", "3", "2", "", "", "Frequent", "Moyen", "acrosome", "CORPS ÉLEVÉ(E) / EXTRÊME", "acro", "some", "3", "2", "", "somato", "Frequent", "Frequent", "actinifère", "PORTER DU RAYON", "actini", "fère", "3", "2", "", "", "Rare", "Frequent", "actinique", "À PROPOS DU RAYON", "actin", "ique", "3", "2", "", "", "Moyen", "Frequent", "actinisme", "DOCTRINE / ÉTAT / PROFESSION DU RAYON", "actin", "isme", "3", "2", "", "", "Moyen", "Frequent", "actinite", "INFLAMMATION DU RAYON", "actin", "ite", "3", "2", "", "", "Moyen", "Frequent", "actinologie", "ÉTUDE DU RAYON", "actino", "logie", "3", "1", "", "logo", "Moyen", "Frequent", "actinologique", "ÉTUDE DU RAYON", "actino", "logique", "3", "1", "", "logo", "Moyen", "Frequent", "actinomètre", "MESUREUR DU RAYON", "actino", "mètre", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinométrie", "MESURE DU RAYON", "actino", "métrie", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinométrique", "MESURAGE DU RAYON", "actino", "métrique", "3", "1", "", "métro (métron)", "Moyen", "Frequent", "actinomorphe", "FORME DU RAYON", "actino", "morphe", "3", "1", "", "morpho", "Moyen", "Frequent", "actinomycète", "CHAMPIGNON DU RAYON", "actino", "mycète", "3", "2", "", "", "Moyen", "Moyen", "actinomycose", "CHAMPIGNON DU RAYON", "actino", "mycose", "3", "2", "", "", "Moyen", "Moyen", "actinopode", "PIED DU RAYON", "actino", "pode", "3", "2", "", "", "Moyen", "Frequent", "actinoscopie", "EXAMEN DU RAYON", "actino", "scopie", "3", "1", "", "scope", "Moyen", "Frequent", "actinothérapie", "MÉDECINE DU RAYON", "actino", "thérapie", "3", "1", "", "thérapie", "Moyen", "Frequent", "actinotropisme", "ATTIRANCE DU RAYON", "actino", "tropisme", "3", "2", "", "trope", "Moyen", "Frequent", "acyclique", "CIRCULARITÉ SANS", "a", "cyclique", "1", "1", "a", "cyclo", "Frequent", "Frequent" } #End If Dim iNbItems% = lstMots.Count Dim iNbMots% = iNbItems / clsMotExistant.iNbColonnesME For i As Integer = 0 To iNbMots - 1 Dim mot As clsMotExistant = Nothing If Not bLireMot(lstMots, i, mot) Then If bDebug Then Stop Continue For End If dicoMotsExistants.Add(mot.sMot, mot) Next End Sub End Module modListePrefixes.vb Module modListePrefixes Public Sub InitialisationPrefixes(sCheminLogotronCsv$, sModeLecture$, msgDelegue As clsMsgDelegue) ' Préfixe : Adjectifs ou noms avec déterminant pour compléments de nom If sModeLecture = enumModeLecture.sCsv Then LireLogotronCsv(sCheminLogotronCsv, msgDelegue) Exit Sub End If If sModeLecture = enumModeLecture.sJSon Then LireLogotronJSon() Exit Sub End If ' Cette liste peut être récupérée via PrefixesSuffixes2.txt Dim prefixes = New List(Of String) From { "a", "sans", "D", "1", "Du grec ancien ἀ-, a- exprimant la privation.", "a", "Grec", "Frequent", "acanth", "l'épine", "D", "3", "Du grec ἄκανθος, akanthos (« épine »).", "acantho", "Grec", "Rare", "acantho", "l'épine", "L", "3", "Du grec ἄκανθος, akanthos (« épine »).", "acantho", "Grec", "Moyen", "acou", "l'audition", "L", "2", "Du grec ancien ἀκούω, akoúô (« entendre »).", "", "Grec", "Moyen", "acro", "élevé(e) / extrême", "L", "3", "Du grec ancien ἄκρος, acros (« élevé, extrême »).", "", "Grec", "Frequent", "actin", "le rayon", "D", "3", "Du grec ancien ἀκτίς, ἀκτίνος, actis, actinos (« rayon »).", "", "Grec", "Moyen", "actini", "le rayon", "D", "3", "Du grec ancien ἀκτίς, ἀκτίνος, actis, actinos (« rayon »).", "", "Grec", "Rare", "actino", "le rayon", "L", "3", "Du grec ancien ἀκτίς, ἀκτίνος, actis, actinos (« rayon »).", "", "Grec", "Moyen", "acu", "l'aiguille", "L", "2", "Du latin acus (« aiguille »).", "", "Latin", "Absent", "addicto", "l'addiction", "L", "1", "De l'anglais addict.", "", "Anglais", "Rare", "adén", "la glande", "D", "3", "", "", "Gréco-latin", "Moyen", "adéno", "la glande", "L", "3", "", "", "Gréco-latin", "Moyen", "aéro", "l'air", "L", "1", "Du grec ancien ἀήρ, aêr.", "", "Grec", "Frequent", "agora", "le lieu public", "L", "2", "Du grec ancien ἀγορά agorá (« assemblée, place publique »).", "", "Grec", "Rare", "agri", "le champ", "L", "1", "Du latin ager, agri, (« champs »).", "", "Latin", "Rare", "agro", "le champ", "L", "1", "Du grec ancien ἀγρός, agros (« champs »).", "", "Grec", "Frequent", "algo", "la douleur", "L", "2", "Du grec ancien ἄλγος algos (« douleur »).", "", "Grec", "Moyen", "allo", "l'autre", "L", "3", "Du grec ancien ἄλλος, allos (« autre »).", "allo", "Grec", "Frequent", "alter", "l'autre", "L", "2", "Du latin alter (« autre »).", "", "Latin", "Absent", "alti", "élevé(e)", "L", "2", "Du latin altus (« élevé »).", "", "Latin", "Moyen", "ambi", "double", "L", "2", "Du latin ambi-.", "ambi", "Latin", "Rare", "amnio", "le bassin", "L", "3", "Du grec ancien ἀμνίον, amníov (« bassin »).", "", "Grec", "Moyen", "amph", "des deux côtés", "D", "3", "Du grec ancien ἀμφίς, amphís (« des deux côtés »).", "", "Grec", "Rare", "amphi", "des deux côtés", "L", "3", "Du grec ancien ἀμφίς, amphís (« des deux côtés »).", "", "Grec", "Moyen", "ampho", "des deux côtés", "L", "3", "Du grec ancien ἀμφίς, amphís (« des deux côtés »).", "", "Grec", "Rare", "amyl", "la farine / l'amidon", "D", "3", "Du grec ancien ἄμυλον, amylon (« farine »).", "", "Grec", "Rare", "amylo", "la farine / l'amidon", "L", "3", "Du grec ancien ἄμυλον, amylon (« farine »).", "", "Grec", "Moyen", "an", "sans", "D", "2", "", "an", "Gréco-latin", "Frequent", "ana", "l'autre / à travers / à nouveau / vers le haut", "L", "3", "", "", "Gréco-latin", "Frequent", "andr", "l'homme / le male", "D", "2", "Du grec ancien ἀνδρός, andrós, génitif singulier de ἀνήρ, anếr (« homme »).", "andro", "Grec", "Moyen", "andro", "l'homme / le male", "L", "2", "Du grec ancien ἀνδρός, andrós, génitif singulier de ἀνήρ, anếr (« homme »).", "andro", "Grec", "Frequent", "anémo", "le vent", "L", "3", "Du grec ancien ἄνεμος, ánemos (« vent »).", "", "Grec", "Moyen", "angéio", "le vaisseau", "L", "3", "Du grec ancien ἀγγεῖον, angeîon (« vase, capsule, vaisseau »).", "", "Grec", "Moyen", "angi", "le vaisseau", "L", "3", "Du grec ancien ἀγγεῖον, angeîon (« vase, capsule, vaisseau »).", "", "Grec", "Moyen", "angio", "le vaisseau", "L", "3", "Du grec ancien ἀγγεῖον, angeîon (« vase, capsule, vaisseau »).", "", "Grec", "Frequent", "angusti", "étroit(e)", "L", "3", "Du latin angustus (« étroit »).", "angusti", "Latin", "Rare", "ankylo", "courbé(e) -> raide / affaibli(e) / insensible", "L", "3", "Du grec ancien ἀγκύλος, ankýlos (« courbé »).", "", "Grec", "Rare", "ant", "contre", "D", "1", "Du grec ancien ἀντί, anti- (« contre »).", "anti", "Latin", "Absent", "anté", "antérieur", "L", "2", "Du latin ante (« avant »).", "", "Latin", "Rare", "anth", "la fleur", "D", "2", "Du grec ancien ἄνθος, ánthos (« fleur »).", "antho", "Grec", "Rare", "antho", "la fleur", "L", "2", "Du grec ancien ἄνθος, ánthos (« fleur »).", "antho", "Grec", "Moyen", "anthraco", "le charbon", "L", "2", "Du grec ancien ἄνθραξ, ánthrax (« charbon »).", "", "Grec", "Rare", "anthrop", "l'homme", "D", "2", "Du grec ancien ἄνθρωπος, ánthrôpos (« être humain »).", "anthropo", "Grec", "Rare", "anthropo", "l'homme", "L", "2", "Du grec ancien ἄνθρωπος, ánthrôpos (« être humain »).", "anthropo", "Grec", "Frequent", "anti", "contre", "L", "1", "Du grec ancien ἀντί, anti (« au lieu de », « en comparaison de », « contre ») dont est issu anti.", "anti", "Grec", "Frequent", "anto", "contre", "L", "1", "Cf. anti : antonyme : Du grec ancien ἀντί, anti- (« contre ») et ὄνομα, onoma (« nom »).", "", "Grec", "Absent", "anxio", "inquiet", "L", "2", "Du latin anxiosus, de anxius (« inquiet »), radical de l’adjectif anxieux.", "", "Latin", "Rare", "api", "l'abeille", "L", "2", "Du latin apis (« abeille »).", "", "Latin", "Moyen", "apic", "le sommet", "D", "3", "Du latin apex (« sommet »).", "", "Latin", "Absent", "apico", "le sommet", "L", "3", "Du latin apex (« sommet »).", "", "Latin", "Absent", "apo", "hors", "L", "3", "Du grec ancien ἀπό, apó (« hors de »).", "apo", "Grec", "Frequent", "aqu", "l'eau", "D", "1", "Du latin aqua (« eau »).", "aqua", "Latin", "Rare", "aqua", "l'eau", "L", "1", "Du latin aqua (« eau »).", "aqua", "Latin", "Moyen", "arbori", "l'arbre", "L", "1", "Du latin arbor (« arbre »).", "arbori", "Latin", "Rare", "arché", "ancien(ne)", "D", "1", "", "archéo", "Gréco-latin", "Rare", "archéo", "ancien(ne)", "L", "1", "", "archéo", "Gréco-latin", "Moyen", "archi", "le gouverneur -> supérieur(e)", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Rare", "aréo", "léger(ère)", "L", "3", "Du grec ancien ἀραιόω, areo, « rendre moins dense, raréfier », basé sur ἀραιός, areos, « mince, étroit, peu profond », à ne pas confondre avec : aéro- : l'air : Du grec ancien ἀήρ, aêr.", "", "Grec", "Moyen", "aristo", "excellent(e)", "L", "2", "Du grec. aristos (« excellent »).", "", "Grec", "Rare", "arithm", "le nombre", "D", "2", "Du grec ancien ἀριθμός, arithmos (« nombre »).", "", "Grec", "Absent", "arithmé", "le nombre", "L", "2", "Du grec ancien ἀριθμός, arithmos (« nombre »).", "", "Grec", "Absent", "arithmo", "le nombre", "L", "2", "Du grec ancien ἀριθμός, arithmos (« nombre »).", "", "Grec", "Moyen", "arthro", "l'articulation", "L", "2", "", "", "Gréco-latin", "Moyen", "astro", "le ciel", "L", "1", "", "astro", "Gréco-latin", "Frequent", "atmo", "la vapeur, l'air", "L", "2", "Du grec ancien ἀτμός, atmós (« vapeur »).", "", "Grec", "Moyen", "atto", "10^-18", "L", "3", "Du danois atten (« dix-huit »), car dix-huit est l’exposant de 10−1 dans 10−18.", "", "Danois", "Absent", "audi", "le son", "D", "1", "Du latin audire (« écouter »).", "audio", "Latin", "Rare", "audio", "le son", "L", "1", "Du latin audire (« écouter »).", "audio", "Latin", "Moyen", "auri", "l'or", "L", "2", "", "auri", "Gréco-latin", "Rare", "auriculo", "l'oreille", "L", "3", "Du latin auricula (lobe de l'oreille). Formé du radical auris (oreille) et du suffixe -culus (petit).", "", "Latin", "Rare", "auto", "de soi-même", "L", "1", "", "", "Gréco-latin", "Frequent" } m_prefixes.DefinirSegments(prefixes, iNbColonnes) End Sub End Module modListeSuffixes.vb Module modListeSuffixes Public Sub InitialisationSuffixes(sModeLecture$) ' Suffixes : If sModeLecture <> enumModeLecture.sCode Then Exit Sub ' Cette liste peut être récupérée via PrefixesSuffixes2.txt Dim suffixes = New List(Of String) From { "able", "qui peut être", "D", "1", "Du latin -abilis (« capable de »), suffixe formateur de noms sur la base de verbes en -are.", "", "Latin", "Frequent", "acanthe", "épine", "L", "3", "Du grec ἄκανθος, akanthos (« épine »).", "acantho", "Grec", "Rare", "acousie", "audition", "L", "2", "Du grec ancien ἀκούω, akoúô (« entendre »).", "", "Grec", "Moyen", "adelphe", "frère", "L", "3", "Du grec ancien ἀδελφός, adelphós (« utérin, frère »).", "", "Grec", "Rare", "adelphie", "frère", "L", "3", "Du grec ancien ἀδελφός, adelphós (« utérin, frère »).", "", "Grec", "Absent", "agogie", "guidage", "L", "2", "Du grec ancien ἀγωγή, agôgê (« action de mener ») ou ἀγωγός, agôgos (« qui conduit, qui guide ») dérivé de ἄγω, agô (« mener »).", "agogie : guider", "Grec", "Moyen", "agogique", "guidage", "D", "2", "Du grec ancien ἀγωγή, agôgê (« action de mener ») ou ἀγωγός, agôgos (« qui conduit, qui guide ») dérivé de ἄγω, agô (« mener »).", "agogie : guider", "Grec", "Moyen", "agogue", "meneur", "L", "2", "Du grec ancien ἀγωγή, agôgê (« action de mener ») ou ἀγωγός, agôgos (« qui conduit, qui guide ») dérivé de ἄγω, agô (« mener »).", "agogie : guider", "Grec", "Moyen", "agogue", "conduction -> écoulement", "L", "2", "Du grec ancien ἀγωγή, agôgê (« action de mener ») ou ἀγωγός, agôgos (« qui conduit, qui guide ») dérivé de ἄγω, agô (« mener »).", "agogie : écouler", "Grec", "Moyen", "algésie", "douleur", "L", "2", "Du grec ancien ἄλγος algos (« douleur »).", "", "Grec", "Moyen", "algésique", "douleur", "D", "2", "Du grec ancien ἄλγος algos (« douleur »).", "", "Grec", "Rare", "algie", "douleur", "L", "2", "Du grec ancien ἄλγος algos (« douleur »).", "", "Grec", "Frequent", "algique", "douleur", "D", "2", "Du grec ancien ἄλγος algos (« douleur »).", "", "Grec", "Moyen", "amniotique", "bassin", "D", "3", "Du grec ancien ἀμνίον, amníov (« bassin »).", "", "Grec", "Rare", "andre", "homme -> male", "L", "2", "Du grec ancien ἀνδρός, andrós, génitif singulier de ἀνήρ, anếr (« homme »).", "andro", "Grec", "Moyen", "andrie", "homme -> male", "L", "2", "Du grec ancien ἀνδρός, andrós, génitif singulier de ἀνήρ, anếr (« homme »).", "andro", "Grec", "Moyen", "anthe", "fleur", "L", "2", "Du grec ancien ἄνθος, ánthos (« fleur »).", "antho", "Grec", "Rare", "anthème", "fleur", "L", "2", "Du grec ancien ἄνθημα, anthêma (« inflorescence »).", "antho", "Grec", "Rare", "anthrope", "homme", "L", "2", "Du grec ancien ἄνθρωπος, ánthrôpos (« être humain »).", "anthropo", "Grec", "Rare", "anthropie", "homme", "L", "2", "Du grec ancien ἄνθρωπος, ánthrôpos (« être humain »).", "anthropo", "Grec", "Rare", "anthropique", "homme", "D", "2", "Du grec ancien ἄνθρωπος, ánthrôpos (« être humain »).", "anthropo", "Grec", "Rare", "arcat", "gouvernement", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Rare", "arche", "gouverneur", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Rare", "archie", "gouvernance", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Moyen", "archique", "gouvernance", "D", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Moyen", "archisme", "gouvernance", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Rare", "arque", "gouverneur", "L", "2", "Du grec ancien ἀρχι-, arkhi-, dérivé de ἄρχω, árkhô (« commencer, mener, gouverner »).", "arche", "Grec", "Moyen", "asthénie", "faiblesse", "L", "3", "Du grec ancien ἀσθένεια, asthéneia (« faiblesse, absence de force »).", "", "Grec", "Moyen", "ateur", "agent", "D", "1", "Du latin -or ou -ator qui donne -our en ancien français, puis -eur en moyen français.", "", "Latin", "Moyen", "athlon", "sport", "L", "2", "Du latin athlon (« concours »).", "", "Latin", "Rare", "ation", "action", "D", "2", "Du latin -atio.", "ation", "Latin", "Frequent", "âtre", "un peu", "L", "2", "Du latin -aster.", "", "Latin", "Rare", "atrice", "agente", "D", "2", "", "", "Gréco-latin", "Moyen" } m_suffixes.DefinirSegments(suffixes, iNbColonnes) End Sub End Module modLogotron.vb ' Source : Jean-Pierre Petit, d'après une 1ère version pour Apple II ' et transcrit d'après la source programmé en Javascript par Daniel Oddon ' https://www.jp-petit.org/Divers/LOGOTRON/logotron.HTM ' http://jeux.javascript.free.fr/logotron/logotron.htm Imports System.Text Module modLogotron 'Public bDebugSegmentLettre1 As Boolean = bDebug 'Public bDebugRacineNiveau As Boolean = False 'Public bDebugSegmentNiveau As Boolean = bDebug 'Public bDebugSensMultiple As Boolean = bDebug Private Const sTermO$ = "o" Private Const sTermOTiret$ = "o-" Private Class clsSensRacine Public sSens$ = "" Public sSensUniqueConcept$ ' Sens normalisé pour le concept 20/10/2018 Public sRacine$ = "" Public iNbRacines% = 0 Public lstRacines As New List(Of String) 'Public lstVariantesSens As New List(Of String) ' Racines multiples Public iSelectMax% ' 0 : non sélect., 1 : dico, 2 : Logotron Public iNiveau% Public sOrigine$ ' 28/08/2018 End Class Private Class clsSensSegment ' Préfixe ou suffixe Public bPrefixe As Boolean ' Sinon suffixe Public sSensSegment$ ' Ex.: le son / son Public sSensUniqueConcept$ ' Sens normalisé pour le concept 20/10/2018 Public sSegmentUnique$ Public sSegment$ ' Ex.: phono- ou phon- / -phone, -phonie, -phonique, -phonisme Public lstVariantes As New List(Of String) ' Ex.: -phone, -phonie, -phonique, -phonisme Public iSelectMax% ' 0 : non sélect., 1 : dico, 2 : Logotron Public iNiveau% Public lstSens As New List(Of String) ' Racines multiples Public sOrigine$ ' 28/08/2018 End Class Private Class clsSegment Public bPrefixe As Boolean ' Sinon suffixe Public sSegmentUnique$ Public sSegment$ ' Ex.: -mane Public sSens$ ' Presque tjrs 1 seul sens Public sSensUniqueConcept$ ' Sens normalisé pour le concept 20/10/2018 Public lstSens As New List(Of String) ' Ex.: -mane : main, maniaque 'Public lstSensM As New List(Of String) ' Racines multiples Public lstVariantes As New List(Of String) ' Ex.: -phone, -phonie, -phonique, -phonisme Public iSelectMax% ' 0 : non sélect., 1 : dico, 2 : Logotron Public iNiveau% Public sOrigine$ ' 28/08/2018 End Class Private m_dicoSensConcept As New Dictionary(Of String, String) ' 20/10/2018 Private Function bLireSensConcept(sCheminSensConcept$) As Boolean ' 20/10/2018 Normalisation des concepts If Not bFichierExiste(sCheminSensConcept, bPrompt:=True) Then Return False Dim asSC = asLireFichier(sCheminSensConcept, bLectureSeule:=True) ', bUnicodeUTF8:=True) Dim lstSC = asSC.ToList Dim hsSC As New HashSet(Of String) If Not bListToHashSet(lstSC, hsSC, bPromptErr:=True) Then Return False m_dicoSensConcept = New Dictionary(Of String, String) Dim iNumLigne% = 0 For Each sLigne In hsSC iNumLigne += 1 If iNumLigne = 1 Then Continue For Dim asChamps() = sLigne.Split(";"c) Dim iNbChamps% = asChamps.GetUpperBound(0) + 1 If iNbChamps <> 2 Then Continue For Dim sCle = asChamps(0) Dim sSensConceptUnique = asChamps(1) If m_dicoSensConcept.ContainsKey(sCle) Then 'm_msgDelegue.AfficherMsg("Sens concept, clé en double : " & sCle) 'If m_msgDelegue.m_bAnnuler Then Exit For MsgBox("Sens concept, clé en double : " & sCle & vbLf & sCheminSensConcept, MsgBoxStyle.Critical, m_sTitreMsg & " : Lecture du fichier " & _ IO.Path.GetFileName(sCheminSensConcept)) Else m_dicoSensConcept.Add(sCle, sSensConceptUnique) End If Next Return True End Function Public Sub LireLogotronCsv(sCheminLogotronCsv$, msgDelegue As clsMsgDelegue) If Not bFichierExiste(sCheminLogotronCsv, bPrompt:=True) Then Exit Sub Dim asLignes$() = asLireFichier(sCheminLogotronCsv, bLectureSeule:=True, bUnicodeUTF8:=True) Dim dicoUniciteRacine As New Dictionary(Of String, String) Dim iNumLigne% = 0 Dim iNbLignes% = asLignes.Count For Each sLigne In asLignes iNumLigne += 1 If iNumLigne = 1 Then Continue For ' Ignorer l'entête Dim asChamps() = sLigne.Split(";"c) Dim iNbChamps% = asChamps.GetUpperBound(0) + 1 Dim sSelect$, sNiveau$, sSegment$, sPrefixe$, sSuffixe$, sSens$, sEtym$ Dim sSegmentTiret$, sUnicite$, sOrigine$, sFrequence$, sListeMotsExcl$ sSegmentTiret = "" : sUnicite = "" : sOrigine = "" : sFrequence = "" sSelect = "" : sNiveau = "" : sListeMotsExcl = "" sSegment = "" : sPrefixe = "" : sSuffixe = "" : sSens = "" : sEtym = "" Dim iNiveau% = 0 'If iNbChamps >= 1 Then sLettre = asChamps(0) If iNbChamps >= 2 Then sSelect = asChamps(1) If sSelect = sNonSelectNum Then Continue For ' Ignorer les lignes avec 0 ' Ignorer les lignes avec 1 (sauf si on veut la liste complète pour ' l'analyse du dictionnaire français) 'If Not bComplet AndAlso sSelect = "1" Then Continue For Dim iSelect% = iSelectDictionnaire Dim bSelectLogotron As Boolean = False If sSelect = sSelectLogotronNum Then _ bSelectLogotron = True : iSelect = iSelectLogotron If iNbChamps >= 3 Then sNiveau = asChamps(2) iNiveau = Integer.Parse(sNiveau) ' 26/11/2017 End If If iNbChamps >= 4 Then sSegment = asChamps(3) If iNbChamps >= 5 Then sPrefixe = asChamps(4) If iNbChamps >= 6 Then sSuffixe = asChamps(5) If iNbChamps >= 7 Then sSens = asChamps(6) If iNbChamps >= 8 Then sEtym = asChamps(7) If iNbChamps >= 9 Then sUnicite = asChamps(8) 'If iNbChamps >= 10 Then sExplication = asChamps(9) 'If iNbChamps >= 11 Then sExemples = asChamps(10) If iNbChamps >= 12 Then sOrigine = asChamps(11) ' 16/06/2018 If sOrigine = enumOrigine.sGrec Then ' Ok ElseIf sOrigine = enumOrigine.sLatin Then ' Ok ElseIf String.IsNullOrEmpty(sOrigine) Then sOrigine = enumOrigine.sDefaut ' Si non précisé, alors Greco-latin ElseIf sOrigine = enumOrigine.sNeologismeAmusant Then If Not bInclureNeologismesAmusants Then Continue For Else 'sOrigine = enumOrigine.sAutre ' Sinon Autre origine (Anglais, ...) End If End If If iNbChamps >= 13 Then sFrequence = asChamps(12) ' 01/07/2018 ' 23/08/2018 If String.IsNullOrEmpty(sFrequence) Then sFrequence = enumFrequence.Defaut End If If iNbChamps >= 14 Then sListeMotsExcl = asChamps(13) ' 31/08/2018 Dim suffixe As New clsSegmentBase Dim prefixe As New clsSegmentBase Dim bPrefixe As Boolean = False If sPrefixe.Length > 0 Then bPrefixe = True sSegmentTiret = sPrefixe ' N'enlever qu'un seul - à la fin (garder vice- avec tiret : vice-champion) If sPrefixe.EndsWith("-") Then sPrefixe = sPrefixe.Substring(0, sPrefixe.Length - 1) prefixe.sSegment = sPrefixe prefixe.sSens = sSens Dim sLogotronSrc$ = "D" If bSelectLogotron Then sLogotronSrc = "L" prefixe.sLogotron = sLogotronSrc prefixe.sNiveau = sNiveau prefixe.sEtym = sEtym prefixe.sUnicite = sUnicite prefixe.sOrigine = sOrigine prefixe.sFrequence = sFrequence ElseIf sSuffixe.Length > 0 Then sSegmentTiret = sSuffixe If sSuffixe.StartsWith("-") Then sSuffixe = sSuffixe.Substring(1, sSuffixe.Length - 1) suffixe.sSegment = sSuffixe suffixe.sSens = sSens Dim sLogotronSrc$ = "D" If bSelectLogotron Then sLogotronSrc = "L" suffixe.sLogotron = sLogotronSrc suffixe.sNiveau = sNiveau suffixe.sEtym = sEtym suffixe.sUnicite = sUnicite suffixe.sOrigine = sOrigine suffixe.sFrequence = sFrequence End If If sListeMotsExcl.Length > 0 Then m_defFls.AjouterListe(bPrefixe, sSegment, sSens, sListeMotsExcl) End If If sEtym.Length > 0 Then If sEtym.IndexOf(sGm) > -1 Then 'MsgBox("Erreur : le signe " & sGm & " n'est pas autorisé ici : " & vbLf & ' sSegment & " : " & sEtym, MsgBoxStyle.Information, m_sTitreMsg) msgDelegue.AfficherMsg("Erreur : le signe " & sGm & " n'est pas autorisé ici : " & vbLf & sSegment & " : " & sEtym) Continue For End If End If ' 09/11/2018 Dim sCleUniciteRacine$ = sSegmentTiret If sUnicite.Length > 0 Then sCleUniciteRacine &= ":" & sUnicite If dicoUniciteRacine.ContainsKey(sCleUniciteRacine) Then Dim sSensE = dicoUniciteRacine(sCleUniciteRacine) Dim sMsg$ = "Doublon racine : " & sCleUniciteRacine & " : " & sSens & ", autre sens déjà défini : " & sSensE & ", segment ignoré" msgDelegue.AfficherMsg(sMsg) msgDelegue.AfficherMsg(" (utiliser l'unicité pour créer une racine distincte)") Continue For End If dicoUniciteRacine.Add(sCleUniciteRacine, sSens) If bPrefixe Then m_prefixes.AjouterSegment(prefixe) Else m_suffixes.AjouterSegment(suffixe) End If Next End Sub Private m_bAfficherAvert As Boolean Private m_msgDelegue As clsMsgDelegue Public Sub TraiterEtExporterDonnees(bAfficherAvert As Boolean, msgDelegue As clsMsgDelegue, sCheminSensConcept$) ' Exporter du format csv vers les formats code et json ' Exporter ssi la source de départ est csv If sModeLecture <> enumModeLecture.sCsv Then Exit Sub ' 20/10/2018 Normalisation des concepts If Not bLireSensConcept(sCheminSensConcept) Then Exit Sub m_bAfficherAvert = bAfficherAvert m_msgDelegue = msgDelegue ' Version Logotron seule Dim sbLignesCodeSrc0, sbLignesPCodeSrc0, sbLignesSCodeSrc0 As New StringBuilder ' Version Complète Dim sbLignesCodeSrc, sbLignesPCodeSrc, sbLignesSCodeSrc As New StringBuilder ' Version avec étymologie, ... Dim sbLignesCodeSrc2, sbLignesPCodeSrc2, sbLignesSCodeSrc2 As New StringBuilder Dim sbLignesCodeSrcJSon As New StringBuilder sbLignesCodeSrcJSon.AppendLine("{") sbLignesCodeSrcJSon.AppendLine(" ""segments"": [") ' Racines uniques : préfixes ou suffixes ' (ex.: phono- et -phone sont issus de la même racine) Dim dicoRacines As New DicoTri(Of String, clsSensSegment) ' Segments uniques : préfixes uniques et suffiques uniques ' (ex.: phono- et phon- sont deux variantes du même segment) Dim dicoSegments As New DicoTri(Of String, clsSensSegment) Dim iNbLignes% = m_prefixes.iLireNbSegments() For i As Integer = 0 To iNbLignes - 1 Dim prefixe As clsSegmentBase = Nothing m_prefixes.bLireSegment(i, prefixe) Dim sPrefixe = prefixe.sSegment Dim sSens = prefixe.sSens Dim iNiveau% = prefixe.iNiveau Dim sUnicite = prefixe.sUnicite Dim sOrigine = prefixe.sOrigine Dim sFrequence = prefixe.sFrequence Dim sSegment$ = sPrefixe Dim sSegmentTiret$ = sPrefixe & "-" Dim iSelect = iSelectDictionnaire Dim bSelectLogotron = False If prefixe.sLogotron = sSelectLogotron Then iSelect = iSelectLogotron : bSelectLogotron = True Const bPrefixe As Boolean = True DecompteSegment(sSegment, sSegmentTiret, bPrefixe, iSelect, sSens, sUnicite, dicoSegments, iNiveau, sOrigine) DecompteRacine(sSegment, sSegmentTiret, bPrefixe, iSelect, sSens, sUnicite, dicoRacines, iNiveau, sOrigine) Dim sLigneSrc$ = " " & sGm & sPrefixe & sGm & ", " & sGm & sSens & sGm If bSelectLogotron Then If sbLignesPCodeSrc0.Length > 0 Then sbLignesPCodeSrc0.Append("," & vbCrLf) sbLignesPCodeSrc0.Append(sLigneSrc) End If If sbLignesPCodeSrc.Length > 0 Then sbLignesPCodeSrc.Append("," & vbCrLf) sbLignesPCodeSrc.Append(sLigneSrc) Dim sLogotronSrc$ = "D" If bSelectLogotron Then sLogotronSrc = "L" prefixe.sLogotron = sLogotronSrc sLigneSrc &= ", " & sGm & sLogotronSrc & sGm sLigneSrc &= ", " & sGm & iNiveau.ToString & sGm sLigneSrc &= ", " & sGm & prefixe.sEtym & sGm sLigneSrc &= ", " & sGm & sUnicite & sGm sLigneSrc &= ", " & sGm & sOrigine & sGm ' 16/06/2018 sLigneSrc &= ", " & sGm & sFrequence & sGm ' 01/07/2018 If sbLignesPCodeSrc2.Length > 0 Then sbLignesPCodeSrc2.Append("," & vbCrLf) sbLignesPCodeSrc2.Append(sLigneSrc) TraiterJSon(sbLignesCodeSrcJSon, bPrefixe, sPrefixe, bSelectLogotron, iNiveau.ToString, sSens, prefixe.sEtym, sUnicite, sOrigine, sFrequence, i, iNbLignes) Next iNbLignes = m_suffixes.iLireNbSegments() For i As Integer = 0 To iNbLignes - 1 Dim suffixe As clsSegmentBase = Nothing m_suffixes.bLireSegment(i, suffixe) Dim sSuffixe = suffixe.sSegment Dim sSens = suffixe.sSens Dim iNiveau% = suffixe.iNiveau Dim sUnicite = suffixe.sUnicite Dim sOrigine = suffixe.sOrigine Dim sFrequence = suffixe.sFrequence Dim sSegment$ = sSuffixe Dim sSegmentTiret$ = "-" & sSuffixe Dim iSelect = iSelectDictionnaire Dim bSelectLogotron = False If suffixe.sLogotron = sSelectLogotron Then iSelect = iSelectLogotron : bSelectLogotron = True Const bPrefixe As Boolean = False DecompteSegment(sSegment, sSegmentTiret, bPrefixe, iSelect, sSens, sUnicite, dicoSegments, iNiveau, sOrigine) DecompteRacine(sSegment, sSegmentTiret, bPrefixe, iSelect, sSens, sUnicite, dicoRacines, iNiveau, sOrigine) Dim sLigneSrc$ = " " & sGm & sSuffixe & sGm & ", " & sGm & sSens & sGm If bSelectLogotron Then If sbLignesSCodeSrc0.Length > 0 Then sbLignesSCodeSrc0.Append("," & vbCrLf) sbLignesSCodeSrc0.Append(sLigneSrc) End If If sbLignesSCodeSrc.Length > 0 Then sbLignesSCodeSrc.Append("," & vbCrLf) sbLignesSCodeSrc.Append(sLigneSrc) Dim sLogotronSrc$ = "D" If bSelectLogotron Then sLogotronSrc = "L" suffixe.sLogotron = sLogotronSrc sLigneSrc &= ", " & sGm & sLogotronSrc & sGm sLigneSrc &= ", " & sGm & iNiveau.ToString & sGm sLigneSrc &= ", " & sGm & suffixe.sEtym & sGm sLigneSrc &= ", " & sGm & sUnicite & sGm sLigneSrc &= ", " & sGm & sOrigine & sGm ' 16/06/2018 sLigneSrc &= ", " & sGm & sFrequence & sGm ' 01/07/2018 If sbLignesSCodeSrc2.Length > 0 Then sbLignesSCodeSrc2.Append("," & vbCrLf) sbLignesSCodeSrc2.Append(sLigneSrc) TraiterJSon(sbLignesCodeSrcJSon, bPrefixe, sSuffixe, bSelectLogotron, iNiveau.ToString, sSens, suffixe.sEtym, sUnicite, sOrigine, sFrequence, i, iNbLignes) Next CreerListeRacines(dicoRacines) CreerListeSegments(dicoSegments) sbLignesCodeSrc0.AppendLine("préfixes :") sbLignesCodeSrc0.Append(sbLignesPCodeSrc0).Append(vbCrLf) sbLignesCodeSrc0.AppendLine() sbLignesCodeSrc0.AppendLine("suffixes :") sbLignesCodeSrc0.Append(sbLignesSCodeSrc0) Dim sCheminLogotronTxt$ = Application.StartupPath & "\PrefixesSuffixes.txt" bEcrireFichier(sCheminLogotronTxt, sbLignesCodeSrc0, bEncodageUTF8:=True) sbLignesCodeSrc.AppendLine("préfixes :") sbLignesCodeSrc.Append(sbLignesPCodeSrc).Append(vbCrLf) sbLignesCodeSrc.AppendLine() sbLignesCodeSrc.AppendLine("suffixes :") sbLignesCodeSrc.Append(sbLignesSCodeSrc) sCheminLogotronTxt = Application.StartupPath & "\PrefixesSuffixesComplet.txt" bEcrireFichier(sCheminLogotronTxt, sbLignesCodeSrc, bEncodageUTF8:=True) sbLignesCodeSrc2.AppendLine("préfixes :") sbLignesCodeSrc2.Append(sbLignesPCodeSrc2).Append(vbCrLf) sbLignesCodeSrc2.AppendLine() sbLignesCodeSrc2.AppendLine("suffixes :") sbLignesCodeSrc2.Append(sbLignesSCodeSrc2) Dim sCheminLogotronTxt2$ = Application.StartupPath & "\PrefixesSuffixes2.txt" bEcrireFichier(sCheminLogotronTxt2, sbLignesCodeSrc2, bEncodageUTF8:=True) sbLignesCodeSrcJSon.AppendLine("]}") Dim sCheminLogotronJSon$ = Application.StartupPath & "\Logotron" & sLang & ".json" bEcrireFichier(sCheminLogotronJSon, sbLignesCodeSrcJSon, bEncodageUTF8:=True) End Sub Private Sub TraiterJSon(sbLignesCodeSrcJSon As StringBuilder, bPrefixe As Boolean, sSegment$, bSelectLogotron As Boolean, sNiveau$, sSens$, sEtym$, sUnicite$, sOrigine$, sFrequence$, iNumLigne%, iNbLignes%) sbLignesCodeSrcJSon.AppendLine(" {") Dim sSegmentJson$ = sSegment Dim sType$ = "suffixe" If bPrefixe Then sType = "préfixe" ': sSegmentJson = sSegment Dim sLogotron$ = "false" If bSelectLogotron Then sLogotron = "true" sbLignesCodeSrcJSon.AppendLine(" ""type"": """ & sType & """,") sbLignesCodeSrcJSon.AppendLine(" ""logotron"": " & sLogotron & ",") sbLignesCodeSrcJSon.AppendLine(" ""niveau"": " & sNiveau & ",") sbLignesCodeSrcJSon.AppendLine(" ""segment"": """ & sSegmentJson & """,") sbLignesCodeSrcJSon.AppendLine(" ""sens"": """ & sSens & """,") If sEtym.Length > 0 Then _ sbLignesCodeSrcJSon.AppendLine(" ""étymologie"": """ & sEtym & """,") If sUnicite.Length > 0 Then _ sbLignesCodeSrcJSon.AppendLine(" ""unicité"": """ & sUnicite & """,") If sOrigine.Length > 0 Then _ sbLignesCodeSrcJSon.AppendLine(" ""origine"": """ & sOrigine & """,") If sFrequence.Length > 0 Then _ sbLignesCodeSrcJSon.AppendLine(" ""fréquence"": """ & sFrequence & """,") sbLignesCodeSrcJSon.Append(" }") If iNumLigne < iNbLignes Then sbLignesCodeSrcJSon.Append(",") sbLignesCodeSrcJSon.AppendLine("") End Sub Public Class clsLogotronJson Public segments As clsLogotronSegmentJson() 'Public segment As clsLogotronSegmentJson End Class Public Class clsLogotronSegmentJson Public type As String Public logotron As Boolean Public niveau As Integer Public segment As String Public sens As String Public étymologie As String Public unicité As String Public origine As String ' 16/06/2018 Public fréquence As String ' 01/07/2018 End Class Public Sub LireLogotronJSon() Const bMajListeCsv As Boolean = True Dim sCheminJson$ = Application.StartupPath & "\Logotron" & sLang & ".json" Dim aStr$() = asLireFichier(sCheminJson, bUnicodeUTF8:=True) Dim sb As New StringBuilder For Each sLigne In aStr sb.AppendLine(sLigne) Next Dim json$ = sb.ToString Dim lignes As clsLogotronJson Try lignes = Newtonsoft.Json.JsonConvert.DeserializeObject(Of clsLogotronJson)(json) Catch ex As Exception AfficherMsgErreur2(ex, "LireLogotronJSon") Exit Sub End Try ' Racines uniques : préfixes ou suffixes ' (ex.: phono- et -phone sont issus de la même racine) Dim dicoRacines As New DicoTri(Of String, clsSensSegment) ' Segments uniques : préfixes uniques et suffiques uniques ' (ex.: phono- et phon- sont deux variantes du même segment) Dim dicoSegments As New DicoTri(Of String, clsSensSegment) For Each seg In lignes.segments ' 21/06/2018 If Not bInclureNeologismesAmusants AndAlso seg.origine = enumOrigine.sNeologismeAmusant Then Continue For End If Dim sSegmentTiret$ = "" Dim bPrefixe As Boolean = False If seg.type = "préfixe" Then bPrefixe = True sSegmentTiret = seg.segment & "-" Else sSegmentTiret = "-" & seg.segment End If Dim sSelect$ = sSelectDictionnaire Dim iSelect% = iSelectDictionnaire If seg.logotron Then iSelect = iSelectLogotron : sSelect = sSelectLogotron If IsNothing(seg.unicité) Then seg.unicité = "" 'If IsNothing(seg.sens) Then seg.sens = "" If IsNothing(seg.étymologie) Then seg.étymologie = "" Dim suffixe As New clsSegmentBase Dim prefixe As New clsSegmentBase If bPrefixe Then prefixe.sSegment = seg.segment prefixe.sLogotron = sSelect prefixe.sNiveau = seg.niveau.ToString prefixe.sSens = seg.sens prefixe.sEtym = seg.étymologie prefixe.sUnicite = seg.unicité prefixe.sOrigine = seg.origine ' 16/06/2018 prefixe.sFrequence = seg.fréquence ' 01/07/2018 m_prefixes.AjouterSegment(prefixe) Else suffixe.sSegment = seg.segment suffixe.sLogotron = sSelect suffixe.sNiveau = seg.niveau.ToString suffixe.sSens = seg.sens suffixe.sEtym = seg.étymologie suffixe.sUnicite = seg.unicité suffixe.sOrigine = seg.origine ' 16/06/2018 suffixe.sFrequence = seg.fréquence ' 01/07/2018 m_suffixes.AjouterSegment(suffixe) End If If Not bMajListeCsv Then Continue For DecompteSegment(seg.segment, sSegmentTiret, bPrefixe, iSelect, seg.sens, seg.unicité, dicoSegments, seg.niveau, seg.origine) DecompteRacine(seg.segment, sSegmentTiret, bPrefixe, iSelect, seg.sens, seg.unicité, dicoRacines, seg.niveau, seg.origine) Next If Not bMajListeCsv Then Exit Sub CreerListeRacines(dicoRacines) CreerListeSegments(dicoSegments) End Sub Private Sub DecompteSegment(sSegment$, sSegmentTiret$, bPrefixe As Boolean, iSelect%, sSens$, sUnicite$, dicoSegments As DicoTri(Of String, clsSensSegment), iNiveau%, sOrigine$) Dim sSensSansArticle$ = sSupprimerArticle(sSens) Dim sSegmentUnique$ = sSegment Dim sCleUniciteSegment$ = bPrefixe & ":" & sSensSansArticle 'sSens 02/12/2017 sSens -> sSensSansArticle 'Dim sCleUniciteSegment$ = bPrefixe & ":" & sSensSansArticle & ":" & sSegmentUnique ' 03/12/2017 If sUnicite.Length > 0 Then sCleUniciteSegment = bPrefixe & ":" & sUnicite ' On corrige certains oublis (le chant), par contre, on duplique toutes les lignes ' pour lesquelles le sens est légèrement décliné (les variations avec agogie) : ' P;L;N3;mélos;mélo-;le membre; : manque "le chant" ' -> Ok (mélos) ' P;L;N3;mélos;mélo-;le membre; ' P;L;N2;mélos;mélo-;le chant; 'sCleUniciteSegment = bPrefixe & ":" & sSensSansArticle & ":" & sUnicite ' 03/12/2017 ' S;L;N2;agogie;-agogie;guider;-agogie, -agogique, -agogue : bien ' -> Non ! pas besoin ! (agogie) ' S;L;N2;agogie;-agogie;guider; ' S;D;N2;agogie;-agogique;guidage; ' S;L;N2;agogie;-agogue;meneur; ' S;L;N2;agogie;-agogue;conduction -> écoulement; ' Solution : préciser le sens dans l'unicité, si on veut les distinguer ' P;L;N2;mélos : chant;mélo-;le chant; ' S;L;N3;mélos : membre;-mèle;membre;-mèle, -mélie ' P;L;N3;mélos : membre;mélo-;le membre; sSegmentUnique = sUnicite End If If Not dicoSegments.ContainsKey(sCleUniciteSegment) Then Dim sensSeg As New clsSensSegment sensSeg.bPrefixe = bPrefixe sensSeg.sSegmentUnique = sSegmentUnique sensSeg.sSegment = sSegment sensSeg.sSensSegment = sSens ' On peut laisser l'article, car on ne mélange pas avec les préfixes 'sensSeg.sSensSegment = sSensSansArticle 'sSens sensSeg.lstVariantes.Add(sSegmentTiret) sensSeg.iSelectMax = iSelect sensSeg.iNiveau = iNiveau sensSeg.sOrigine = sOrigine ' 28/08/2018 dicoSegments.Add(sCleUniciteSegment, sensSeg) Else Dim sensSeg = dicoSegments(sCleUniciteSegment) Dim bExiste As Boolean = False For Each sVariante In sensSeg.lstVariantes If sVariante = sSegmentTiret Then bExiste = True : Exit For Next If Not bExiste Then sensSeg.lstVariantes.Add(sSegmentTiret) ' Si une variante de racine se termine par o ' et que le segment principal ne se termine pas par o ' alors préférer cette variante comme segment principal ' Ex.: métall- et métallo- : préférer métallo- If sSegment = sensSeg.sSegmentUnique AndAlso sensSeg.sSegment <> sensSeg.sSegmentUnique Then sensSeg.sSegment = sensSeg.sSegmentUnique End If End If ' Noter le niveau max. atteint par une variante ' (si aucune variante n'atteint le niveau 2, ' alors le segment reste au niveau 1) If iSelect > sensSeg.iSelectMax Then sensSeg.iSelectMax = iSelect If m_bAfficherAvert AndAlso iNiveau <> sensSeg.iNiveau Then m_msgDelegue.AfficherMsg("Segment : " & sSegmentUnique & " : " & sensSeg.sSensSegment & " : Niveau " & iNiveau & " <> " & sensSeg.iNiveau) End If End If End Sub Private Sub DecompteRacine(sSegment$, sSegmentTiret$, bPrefixe As Boolean, iSelect%, sSens$, sUnicite$, dicoRacines As DicoTri(Of String, clsSensSegment), iNiveau%, sOrigine$) Dim sSensSansArticle$ = sSupprimerArticle(sSens) Dim sCleUniciteRacine$ = sSensSansArticle Dim sSegmentUnique$ = sSegment If sUnicite.Length > 0 Then sCleUniciteRacine = sUnicite sSegmentUnique = sUnicite End If ' 20/10/2018 Dim sSensConceptNormalise$ = sSensSansArticle If m_dicoSensConcept.ContainsKey(sSensSansArticle) Then _ sSensConceptNormalise = m_dicoSensConcept(sSensSansArticle) 'If sSegmentTiret = "strato-" Then ' Debug.WriteLine(sSegmentTiret & " : " & sCleUniciteRacine & " : " & sSensConceptNormalise) 'End If If Not dicoRacines.ContainsKey(sCleUniciteRacine) Then Dim sensSeg As New clsSensSegment sensSeg.bPrefixe = bPrefixe sensSeg.sSegmentUnique = sSegmentUnique sensSeg.sSegment = sSegment sensSeg.sSensSegment = sSensSansArticle sensSeg.sSensUniqueConcept = sSensConceptNormalise ' 20/10/2018 sensSeg.lstVariantes.Add(sSegmentTiret) sensSeg.iSelectMax = iSelect sensSeg.iNiveau = iNiveau sensSeg.lstSens.Add(sSensSansArticle) ' Racines multiples sensSeg.sOrigine = sOrigine ' 28/08/2018 dicoRacines.Add(sCleUniciteRacine, sensSeg) Else Dim sensSeg = dicoRacines(sCleUniciteRacine) Dim bExiste As Boolean = False For Each sVariante In sensSeg.lstVariantes If sVariante = sSegmentTiret Then bExiste = True : Exit For Next If Not bExiste Then sensSeg.lstVariantes.Add(sSegmentTiret) End If ' Racines multiples bExiste = False For Each sSens0 In sensSeg.lstSens If sSens0 = sSensSansArticle Then bExiste = True : Exit For Next If Not bExiste Then sensSeg.lstSens.Add(sSensSansArticle) End If ' Noter le niveau max. atteint par une variante ' (si aucune variante n'atteint le niveau 2, ' alors le segment reste au niveau 1) If iSelect > sensSeg.iSelectMax Then sensSeg.iSelectMax = iSelect ' La complexité d'une racine est celle du minimum des préfixes et suffixes liés If iNiveau < sensSeg.iNiveau Then sensSeg.iNiveau = iNiveau sensSeg.sSensUniqueConcept = sSensConceptNormalise ' 20/10/2018 End If End Sub Private Sub CreerListeRacines(dicoRacines As DicoTri(Of String, clsSensSegment)) Dim dicoSensRacines As New DicoTri(Of String, clsSegment) For Each sensSeg In dicoRacines.Trier("sSegmentUnique, sSensSegment") 'If sensSeg.sSegment = "strati" Then ' Debug.WriteLine(sensSeg.sSensSegment) 'End If 'If sensSeg.sSegment = "strato" Then ' Debug.WriteLine(sensSeg.sSensSegment) 'End If Dim sCleUniciteSens$ = sensSeg.sSegmentUnique Dim seg As clsSegment If Not dicoSensRacines.ContainsKey(sCleUniciteSens) Then seg = New clsSegment seg.bPrefixe = sensSeg.bPrefixe seg.sSegmentUnique = sensSeg.sSegmentUnique seg.sSegment = sensSeg.sSegment seg.lstVariantes = sensSeg.lstVariantes seg.sSens = sensSeg.sSensSegment seg.sSensUniqueConcept = sensSeg.sSensUniqueConcept ' 20/10/2018 seg.lstSens.Add(sensSeg.sSensSegment) 'seg.lstSensM = sensSeg.lstSens.ToList ' Copie de la liste des sens seg.iSelectMax = sensSeg.iSelectMax seg.iNiveau = sensSeg.iNiveau seg.sOrigine = sensSeg.sOrigine ' 28/08/2018 dicoSensRacines.Add(sCleUniciteSens, seg) Else ' Ajouter les sens associés à une racine, si ce n'est pas déjà fait seg = dicoSensRacines(sCleUniciteSens) Dim bExiste As Boolean = False For Each sSens In seg.lstSens If sSens = sensSeg.sSensSegment Then bExiste = True : Exit For Next If Not bExiste Then seg.lstSens.Add(sensSeg.sSensSegment) End If ' Racines multiples 'bExiste = False 'For Each sSens In seg.lstSensM ' If sSens = sensSeg.sSensSegment Then bExiste = True : Exit For 'Next 'If Not bExiste Then ' seg.lstSensM.Add(sensSeg.sSensSegment) 'End If ' Ajouter les variantes associées à une racine, si ce n'est pas déjà fait For Each sVariante In seg.lstVariantes If Not sensSeg.lstVariantes.Contains(sVariante) Then sensSeg.lstVariantes.Add(sVariante) End If Next seg.sSensUniqueConcept = sensSeg.sSensUniqueConcept ' 20/10/2018 End If 'If String.IsNullOrEmpty(seg.sSensSegmentConcept) Then ' Debug.WriteLine("!") 'End If For Each sVariante In seg.lstVariantes ' Si une variante de racine se termine par o ' et que le segment principal ne se termine pas par o ' alors préférer cette variante comme segment principal ' Ex.: métall- et métallo- : préférer métallo- If sVariante.EndsWith(sTermOTiret) AndAlso Not seg.sSegmentUnique.EndsWith(sTermO) AndAlso seg.sSegmentUnique = seg.sSegment Then seg.sSegmentUnique = sVariante.Substring(0, sVariante.Length - 1) seg.sSegment = seg.sSegmentUnique End If Next ' Noter le niveau max. atteint par une variante ' (si aucune variante n'atteint le niveau 2, ' alors le segment reste au niveau 1) If sensSeg.iSelectMax > seg.iSelectMax Then seg.iSelectMax = sensSeg.iSelectMax ' La complexité d'un concept est celle du minimum des racines qui l'exprime If sensSeg.iNiveau < seg.iNiveau Then seg.iNiveau = sensSeg.iNiveau ' Pas besoin, car déjà signalé au niveau segment : 'If bDebugRacineNiveau AndAlso sensSeg.iNiveau <> seg.iNiveau Then ' Debug.WriteLine("Racine : " & seg.sSegmentUnique & " : " & ' seg.sSens & " : Niveau " & sensSeg.iNiveau & " <> " & seg.iNiveau) 'End If Next ' Sens avec des racines distinctes, pour info. Dim dicoSens As New DicoTri(Of String, clsSensRacine) Dim sb As New StringBuilder( "Sel.;Niv.;Racine;Sens;Déclinaisons et variantes;Origine" & vbCrLf) For Each sensSeg In dicoSensRacines.Trier("sSegmentUnique") 'If sensSeg.sSegment = "strato" Then ' Debug.WriteLine(sensSeg.sSensUniqueConcept) 'End If Dim sLigne$ = "" 'sLigne &= sensSeg.iSelectMax & ";" If sensSeg.iSelectMax = 1 Then sLigne &= sSelectDictionnaire & ";" Else sLigne &= sSelectLogotron & ";" End If sLigne &= "N" & sensSeg.iNiveau & ";" ' 26/11/2017 sLigne &= sensSeg.sSegmentUnique & ";" 'If sensSeg.sSegmentUnique = "phago" Then Debug.WriteLine("!") Dim sSensFinal$ = "" Dim iNumSens% = 0 sensSeg.lstSens.Sort() ' 08/04/2018 For Each sSens In sensSeg.lstSens sSensFinal &= sSens iNumSens += 1 If iNumSens < sensSeg.lstSens.Count Then sSensFinal &= ", " If m_bAfficherAvert AndAlso sensSeg.lstSens.Count > 1 Then _ m_msgDelegue.AfficherMsg("Sens racine multiple " & sensSeg.sSegmentUnique & " : " & sSens) Next sLigne &= sSensFinal & ";" 'Dim sCleSensConcept$ = sSensFinal Dim sCleSensConcept$ = sensSeg.sSensUniqueConcept ' 20/10/2018 'If sensSeg.sSegmentUnique = "dendron" Then Debug.WriteLine(sensSeg.sSegmentUnique) 'If sCleSensConcept = "arbre" Then Debug.WriteLine(sensSeg.sSegmentUnique) Dim sr As clsSensRacine If dicoSens.ContainsKey(sCleSensConcept) Then sr = dicoSens(sCleSensConcept) sr.lstRacines.Add(sensSeg.sSegmentUnique) ' Ajout des variantes sr.iNbRacines += 1 sr.sSensUniqueConcept = sensSeg.sSensUniqueConcept ' 20/10/2018 Else sr = New clsSensRacine sr.sSens = sCleSensConcept 'sSensFinal sr.sSensUniqueConcept = sensSeg.sSensUniqueConcept ' 20/10/2018 sr.sRacine = sensSeg.sSegmentUnique sr.iNbRacines = 1 'sr.lstVariantesSens = sensSeg.lstSensM.ToList ' Copie de la liste sr.iSelectMax = sensSeg.iSelectMax sr.iNiveau = sensSeg.iNiveau dicoSens.Add(sCleSensConcept, sr) End If 'If String.IsNullOrEmpty(sr.sSensRacineConcept) Then ' Debug.WriteLine("!") 'End If ' Noter le niveau max. atteint (Logotron ou Dictionnaire) If sensSeg.iSelectMax > sr.iSelectMax Then sr.iSelectMax = sensSeg.iSelectMax ' La complexité d'un concept est celle du minimum des racines qui l'exprime If sensSeg.iNiveau < sr.iNiveau Then sr.iNiveau = sensSeg.iNiveau ' 20/10/2018 Plus besoin : il suffit de compter NbRacines ' Racines multiples 'For Each sSensV In sensSeg.lstSensM ' If sSensV = sCleSensConcept Then Continue For ' If dicoSens.ContainsKey(sSensV) Then ' Dim sr1 = dicoSens(sSensV) ' sr1.lstRacines.Add(sensSeg.sSegmentUnique) ' sr1.iNbRacines += 1 ' ' Noter le niveau max. atteint (Logotron ou Dictionnaire) ' If sensSeg.iSelectMax > sr1.iSelectMax Then sr1.iSelectMax = sensSeg.iSelectMax ' ' La complexité d'un concept est celle du minimum des racines qui l'exprime ' If sensSeg.iNiveau < sr1.iNiveau Then sr1.iNiveau = sensSeg.iNiveau ' Else ' Dim sr1 As New clsSensRacine ' sr1.sSens = sSensV ' sr1.sRacine = sensSeg.sSegmentUnique ' sr1.sSensRacineConcept = sensSeg.sSensSegmentConcept ' 20/10/2018 ' sr1.iNbRacines = 1 ' sr1.iNiveau = sensSeg.iNiveau ' sr1.iSelectMax = sensSeg.iSelectMax ' dicoSens.Add(sSensV, sr1) ' End If 'Next If sensSeg.lstVariantes.Count > 1 Then Dim iNumVar% = 0 Dim sSegment$ = sensSeg.sSegment Dim sCar1$ = sEnleverAccents(sSegment(0)) ', bTexteUnicode:=False) sensSeg.lstVariantes.Sort() ' 07/01/2017 For Each sVariante In sensSeg.lstVariantes sLigne &= sVariante iNumVar += 1 If iNumVar < sensSeg.lstVariantes.Count Then sLigne &= ", " ' Afficher le rapport des préfixes d'une même racine qui ne commencent pas ' par la même lettre : erreur probable (et pareil pour les suffixes) ' Exceptions (il s'agit bien de la même racine, exceptionnellement) : ' kérato- <> cérato, de kéras (« corne ») dont le génitif est kératos. ' -kinèse, kinési-, -kinésie <> cinèse, de kinêsis (« mouvement »). ' -urgie, -urgique <> ergo, de érgon (« travail »). ' -tude <> itude : tude est une variante de itude, du latin -tudo. Dim sCar2$ = "" If sVariante.StartsWith("-") Then If sVariante.Length = 1 Then If bDebug Then Stop Else sCar2 = sVariante(1) End If Else sCar2 = sVariante(0) End If sCar2 = sEnleverAccents(sCar2) ', bTexteUnicode:=False) If m_bAfficherAvert AndAlso iNumVar > 1 AndAlso sCar2 <> sCar1 Then m_msgDelegue.AfficherMsg("Racines : Segment ne commençant pas par la même lettre : " & sVariante & " <> " & sSegment & " : " & sensSeg.sSens) End If Next Else If sensSeg.bPrefixe Then sLigne &= sensSeg.sSegment & "-" Else sLigne &= "-" & sensSeg.sSegment End If End If sLigne &= ";" & sensSeg.sOrigine ' 28/08/2018 sb.AppendLine(sLigne) Next Dim sCheminsRacines$ = Application.StartupPath & "\Racines.csv" bEcrireFichier(sCheminsRacines, sb) ' 26/10/2018 Plus besoin, il suffit de compter le nombre de racines dans les concepts : ' Afficher le rapport des racines multiples : les sens avec des racines distinctes 'sb = New StringBuilder( ' "Racine;Sens;Racines différentes" & vbCrLf) 'Dim hsDiff As New HashSet(Of String) 'For Each racine In dicoSens.Trier("iNbRacines DESC, sRacine") ' If racine.iNbRacines = 1 Then Continue For ' Dim sLigne$ = racine.sRacine & ";" & racine.sSens & ";" ' Dim sRacinesDiff$ = "" ' racine.lstRacines.Sort() ' 18/11/2017 ' For Each sRacineDiff In racine.lstRacines ' If sRacinesDiff.Length > 0 Then sRacinesDiff &= ", " ' sRacinesDiff &= sRacineDiff ' Next ' Dim sDiff = sRacinesDiff & " <> " & racine.sRacine ' If hsDiff.Contains(sDiff) Then Continue For ' sLigne &= sDiff ' sb.AppendLine(sLigne) ' hsDiff.Add(sDiff) 'Next 'Dim sCheminsRacinesMultiples$ = Application.StartupPath & "\RacinesMultiples.csv" 'bEcrireFichier(sCheminsRacinesMultiples, sb) ' Afficher le rapport des concepts distincts ' 26/10/2018 NbRacines ajouté sb = New StringBuilder( "Sel.;Niv.;Concept;Racines;NbRacines" & vbCrLf) Dim hsRacines As New HashSet(Of String) For Each racine In dicoSens.Trier("sSens") 'If racine.sRacine = "magnéto" Then ' Debug.WriteLine(racine.sSensUniqueConcept) 'End If Dim sLigne$ = "" If racine.iSelectMax = 1 Then sLigne &= sSelectDictionnaire & ";" Else sLigne &= sSelectLogotron & ";" End If sLigne &= "N" & racine.iNiveau & ";" 'Dim sConcept$ = racine.sSens Dim sConcept$ = racine.sSensUniqueConcept ' 20/10/2018 'If String.IsNullOrEmpty(sConcept) Then ' Debug.WriteLine("sSensRacineConcept vide : " & racine.sSens) ' sConcept = racine.sSens 'End If sLigne &= sConcept Dim sRacines$ = racine.sRacine For Each sRacine In racine.lstRacines 'If sRacine = racine.sRacine Then Continue For If sRacines.Length > 0 Then sRacines &= ", " sRacines &= sRacine Next ' Il n'existe que 2 concepts avec 2 sens : strato- : strate et armée, pédo- : enfant et sol 'Dim sCleUniciteConcept$ = sRacines Dim sCleUniciteConcept$ = sRacines & ":" & racine.sSensUniqueConcept ' 26/10/2018 If hsRacines.Contains(sCleUniciteConcept) Then Debug.WriteLine("Concept : racine déja existante : " & sCleUniciteConcept & " : " & sLigne) Continue For End If sLigne &= ";" & sRacines & ";" & (racine.lstRacines.Count + 1) sb.AppendLine(sLigne) hsRacines.Add(sCleUniciteConcept) Next Dim sCheminsSens$ = Application.StartupPath & "\Concepts.csv" bEcrireFichier(sCheminsSens, sb) End Sub Private Sub CreerListeSegments(dicoSegments As DicoTri(Of String, clsSensSegment)) Dim dicoSensSeg As New DicoTri(Of String, clsSegment) For Each sensSeg In dicoSegments.Trier("bPrefixe, sSegmentUnique, sSensSegment") Dim sSensSansArticle$ = sSupprimerArticle(sensSeg.sSensSegment) Dim sCleUniciteSens$ = sensSeg.bPrefixe & ":" & sSensSansArticle & ":" & sensSeg.sSegmentUnique ' 03/12/2017 Dim seg As clsSegment If Not dicoSensSeg.ContainsKey(sCleUniciteSens) Then seg = New clsSegment seg.bPrefixe = sensSeg.bPrefixe seg.sSegmentUnique = sensSeg.sSegmentUnique seg.sSegment = sensSeg.sSegment seg.lstVariantes = sensSeg.lstVariantes seg.sSens = sensSeg.sSensSegment seg.lstSens.Add(sensSeg.sSensSegment) seg.iSelectMax = sensSeg.iSelectMax seg.iNiveau = sensSeg.iNiveau seg.sOrigine = sensSeg.sOrigine ' 28/08/2018 dicoSensSeg.Add(sCleUniciteSens, seg) Else seg = dicoSensSeg(sCleUniciteSens) Dim bExiste As Boolean = False For Each sSens In seg.lstSens If sSens = sensSeg.sSensSegment Then bExiste = True : Exit For Next If Not bExiste Then seg.lstSens.Add(sensSeg.sSensSegment) End If ' 03/12/2017 C'est l'inverse 'For Each sVar1 In seg.lstVariantes ' If Not sensSeg.lstVariantes.Contains(sVar1) Then ' sensSeg.lstVariantes.Add(sVar1) ' End If 'Next For Each sVar1 In sensSeg.lstVariantes If Not seg.lstVariantes.Contains(sVar1) Then seg.lstVariantes.Add(sVar1) End If Next End If If sensSeg.bPrefixe Then For Each sVariante In seg.lstVariantes ' Si une variante de racine se termine par o ' et que le segment principal ne se termine pas par o ' alors préférer cette variante comme segment principal ' Ex.: métall- et métallo- : préférer métallo- If sVariante.EndsWith(sTermOTiret) AndAlso Not seg.sSegmentUnique.EndsWith(sTermO) AndAlso seg.sSegmentUnique = seg.sSegment Then seg.sSegmentUnique = sVariante.Substring(0, sVariante.Length - 1) seg.sSegment = seg.sSegmentUnique End If Next End If ' Noter le niveau max. atteint par une variante ' (si aucune variante n'atteint le niveau 2, ' alors le segment reste au niveau 1) If sensSeg.iSelectMax > seg.iSelectMax Then seg.iSelectMax = sensSeg.iSelectMax If m_bAfficherAvert AndAlso sensSeg.iNiveau <> seg.iNiveau Then If seg.lstSens.Count > 1 Then For Each sSens In seg.lstSens m_msgDelegue.AfficherMsg("Segment : " & seg.sSegmentUnique & " : " & sSens & " : Niveau " & sensSeg.iNiveau & " <> " & seg.iNiveau) Next ' S'il y a plusieurs sens, il peut y avoir plusieurs niveaux ' Ex.: mélo- pour mélodie : niveau 2, mais mélo- pour membre : niveau 3 'seg.iNiveau = sensSeg.iNiveau Else m_msgDelegue.AfficherMsg("Segment : " & seg.sSegmentUnique & " : " & seg.sSens & " : Niveau " & sensSeg.iNiveau & " <> " & seg.iNiveau) End If End If Next Dim sb As New StringBuilder( "P/S;Sel.;Niv.;Racine;Segment;Sens;Déclinaisons et variantes;Origine" & vbCrLf) Const sTri$ = "sSegmentUnique, bPrefixe, sSens" For Each sensSeg In dicoSensSeg.Trier(sTri) Dim sLigne$ If sensSeg.bPrefixe Then sLigne = "P;" Else sLigne = "S;" ' Sinon Suffixe End If If sensSeg.iSelectMax = 1 Then sLigne &= sSelectDictionnaire & ";" Else sLigne &= sSelectLogotron & ";" End If sLigne &= "N" & sensSeg.iNiveau & ";" ' 26/11/2017 sLigne &= sensSeg.sSegmentUnique & ";" If sensSeg.bPrefixe Then sLigne &= sensSeg.sSegment & "-" Else sLigne &= "-" & sensSeg.sSegment End If sLigne &= ";" Dim iNumSens% = 0 For Each sSens In sensSeg.lstSens sLigne &= sSens iNumSens += 1 If iNumSens < sensSeg.lstSens.Count Then sLigne &= ", " If m_bAfficherAvert AndAlso sensSeg.lstSens.Count > 1 Then _ m_msgDelegue.AfficherMsg("Sens segment multiple " & sensSeg.sSegmentUnique & " : " & sSens) Next sLigne &= ";" If sensSeg.lstVariantes.Count > 1 Then Dim iNumVar% = 0 sensSeg.lstVariantes.Sort() ' 18/11/2017 For Each sVariante In sensSeg.lstVariantes sLigne &= sVariante iNumVar += 1 If iNumVar < sensSeg.lstVariantes.Count Then sLigne &= ", " Next End If sLigne &= ";" & sensSeg.sOrigine ' 28/08/2018 sb.AppendLine(sLigne) Next Dim sCheminSegments$ = Application.StartupPath & "\Segments.csv" bEcrireFichier(sCheminSegments, sb) End Sub Public Function bTirage(bComplet As Boolean, sNbPrefixesSuccessifs$, lstNiv As List(Of String), lstFreq As List(Of String), bGrecoLatin As Boolean, bNeoRigolo As Boolean, ByRef sMot$, ByRef sExplication$, ByRef sDetail$, ByRef lstEtymFin As List(Of String)) As Boolean Dim lstEtym As New List(Of String) ' 5 préfixes successifs au maximum Dim iNbTiragesPrefixes% = 0 If sNbPrefixesSuccessifs = sHasard Then iNbTiragesPrefixes = iRandomiser(1, 5) 'If bDebug Then iNbTiragesPrefixes = 1 ' Diminution de la probabilité de préfixes successifs Dim rProba! = 1.0! Select Case iNbTiragesPrefixes Case 1 : rProba = 1 ' Toujours accepté Case 2 : rProba = 1 / 2 ' Une fois sur 2 Case 3 : rProba = 1 / 4 ' Une fois sur 4 Case 4 : rProba = 1 / 8 ' Une fois sur 8 Case 5 : rProba = 1 / 16 ' Une fois sur 16 'Case 3 : rProba = 1 / 3 ' Une fois sur 3 'Case 4 : rProba = 1 / 4 ' Une fois sur 4 'Case 5 : rProba = 1 / 5 ' Une fois sur 5 'Case 2 : rProba = 0.1 ' Une fois sur 10 'Case 2 : rProba = 0.2 ' Une fois sur 5 'Case 3 : rProba = 0.1 ' Une fois sur 10 'Case 3 : rProba = 0.05 ' Une fois sur 20 'Case 4 : rProba = 0.03 'Case 5 : rProba = 0.01 ' Une fois sur 100 End Select If rProba < 1 Then Dim rTirage = rRandomiser() If rTirage > rProba Then iNbTiragesPrefixes = 1 End If Else iNbTiragesPrefixes = Integer.Parse(sNbPrefixesSuccessifs) End If Dim sPrefixesMaj$ = "" Dim sSensPrefixesMaj$ = "" Dim sDetailPrefixesMaj$ = "" Dim itPref As New clsInitTirage() For i As Integer = 0 To iNbTiragesPrefixes - 1 Dim iNumPrefixe% = m_prefixes.iTirageSegment(bComplet, lstNiv, lstFreq, itPref, bGrecoLatin, bNeoRigolo) Dim prefixe As clsSegmentBase = Nothing If Not m_prefixes.bLireSegment(iNumPrefixe, prefixe) Then Return False Dim sNiveauP = prefixe.sNiveau Dim sPrefixe = prefixe.sSegment Dim sPrefixeMaj = sPrefixe.ToUpper() Dim sSensPrefixeMaj = prefixe.sSens.ToUpper() sSensPrefixeMaj = sCompleterPrefixe(sSensPrefixeMaj) sPrefixesMaj &= sPrefixeMaj sSensPrefixesMaj &= " " & sSensPrefixeMaj sDetailPrefixesMaj &= sPrefixeMaj & "(" & sNiveauP & ") - " Dim sEtymPrefixe = prefixe.sEtym If sEtymPrefixe.Length > 0 Then lstEtym.Add(sPrefixe & "- : " & sEtymPrefixe) Next 'Dim iNbSuffixes% = m_suffixes.iLireNbSegments Dim iNumSuffixe% = m_suffixes.iTirageSegment(bComplet, lstNiv, lstFreq, New clsInitTirage, bGrecoLatin, bNeoRigolo) Dim suffixe As clsSegmentBase = Nothing If Not m_suffixes.bLireSegment(iNumSuffixe, suffixe) Then Return False Dim sNiveauS = suffixe.sNiveau Dim sSuffixe = suffixe.sSegment Dim sSuffixeMaj = sSuffixe.ToUpper() Dim sDetailSuffixeMaj = sSuffixeMaj & "(" & sNiveauS & ")" Dim sSensSuffixeMaj = suffixe.sSens.ToUpper() sMot = sPrefixesMaj & sSuffixeMaj sExplication = sSensSuffixeMaj & sSensPrefixesMaj sDetail = sDetailPrefixesMaj & sDetailSuffixeMaj Dim sEtymSuffixe = suffixe.sEtym If sEtymSuffixe.Length > 0 Then lstEtym.Add("-" & sSuffixe & " : " & sEtymSuffixe) lstEtymFin = lstEtym Return True End Function End Module modUtil.vb Imports System.Text ' Pour StringBuilder Imports System.Text.Encoding ' Pour GetEncoding Public Module modUtil Public Function rRandomiser!() Dim rRnd! Static rRndGenerateur As New Random Dim rRndDouble As Double = rRndGenerateur.NextDouble rRnd = CSng(rRndDouble) Return rRnd End Function Public Function iRandomiser%(ByVal iMin%, ByVal iMax%) ' La borne sup. est la borne max. possible, la borne min. est la borne min. possible Dim iRes As Integer = 0 If iMin = iMax Then Return iMin Dim rRnd! Static rRndGenerateur As New Random Dim rRndDouble As Double = rRndGenerateur.NextDouble rRnd = CSng(rRndDouble) Dim rVal! = iMin + rRnd * (iMax + 1 - iMin) ' Fix : Partie entière sans arrondir à l'entier le plus proche iRes = iFix(rVal) ' Au cas où Rnd() renverrait 1.0 et qq If iRes > iMax Then iRes = iMax 'Debug.WriteLine("Tirage entier entre " & iMin & " et " & iMax & " = " & iRes) Return iRes End Function Public Function iFix%(ByVal rVal!) ' Fix : Partie entière sans arrondir à l'entier le plus proche ' Pour les nombres négatifs, on enlève la partie décimale aussi ' Floor arrondi les négatifs à l'entier le plus petit, tandis que ' Ceiling arrondi les négatifs à l'entier le plus grand (le plus petit en valeur absolu). ' Fix arrondi toujours à l'entier le plus petit en valeur absolu iFix = CInt(IIf(rVal >= 0, Math.Floor(rVal), Math.Ceiling(rVal))) End Function Public Sub AfficherMsgErreur(ex As Exception, _ Optional sTitreFct$ = "", Optional sInfo$ = "", _ Optional sDetailMsgErr$ = "", _ Optional bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If ex IsNot Nothing AndAlso Not String.IsNullOrEmpty(ex.Message) Then sMsg &= vbCrLf & ex.Message.Trim If ex.InnerException IsNot Nothing AndAlso _ Not String.IsNullOrEmpty(ex.InnerException.Message) Then _ sMsg &= vbCrLf & ex.InnerException.Message End If If bCopierMsgPressePapier Then bCopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Function bCopierPressePapier(sInfo$, Optional ByRef sMsgErr$ = "") As Boolean ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Return True Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur(ex, "CopierPressePapier", bCopierMsgPressePapier:=False, _ sMsgErrFinal:=sMsgErr) Return False End Try End Function Public Sub AfficherMsgErreur2(ex As Exception, _ Optional sTitreFct$ = "", Optional sInfo$ = "", _ Optional sDetailMsgErr$ = "", _ Optional bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Not ex Is Nothing AndAlso Not String.IsNullOrEmpty(ex.Message) Then sMsg &= vbCrLf & ex.Message.Trim If Not IsNothing(ex.InnerException) Then _ sMsg &= vbCrLf & ex.InnerException.Message End If If bCopierMsgPressePapier Then bCopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub TraiterMsgSysteme_DoEvents() Application.DoEvents() End Sub Public Sub AfficherTexteListBox(sTxtOrig$, ByRef iIndexTxtLb%, frm As Form, lb As ListBox) ' Afficher un texte dans une ListBox en découpant au besoin en plusieurs lignes If frm Is Nothing Then Throw New ArgumentNullException("frm") If lb Is Nothing Then Throw New ArgumentNullException("lb") If String.IsNullOrEmpty(sTxtOrig) Then 'Exit Sub GoTo Fin End If ' Pour cela il faut mesurer la largeur du texte affiché de façon précise Dim graphics = frm.CreateGraphics() ' En cas d'affichage intensif, optimiser ici Dim szTxtOrig = graphics.MeasureString(sTxtOrig, lb.Font) Const rFact! = 1.04! ' Selon la police utilisée, il faut appliquer un facteur (ou marge) de correction Dim rLargeurTxtOrig! = szTxtOrig.Width * rFact Dim rLargeurDispo! = lb.Width If rLargeurDispo <= 0 Then Exit Sub ' 24/11/2019 Appli iconisée Dim rDiv! = lb.Width / rLargeurTxtOrig If rDiv < 1 Then ' Le texte ne loge pas, il faut le découper en lignes Dim iLongTot% = sTxtOrig.Length + 1 ' +1 pour le car. saut de ligne ajouté éventuel Dim rNbTroncons! = rLargeurTxtOrig / lb.Width Dim iLongMoyTroncon% = Math.Ceiling(iLongTot / rNbTroncons) ' Arrondi sup. 'Dim iNbTroncons% = Math.Ceiling(rNbTroncons) ' Arrondi sup. Dim iTxtAff% = 0 Dim sTxtFinVerif$ = "" Dim iNumTroncon% = 0 Do Dim iNbCarEnTrop% = 1 ' Tenir compte du saut de ligne ↲ Dim iLongTroncon% = iLongMoyTroncon Dim sTxtTroncon = "" Dim sTxtTronconVerif = "" Dim bFin As Boolean = False Do Dim bAjoutCarSautDeLigne = True Dim iLongRest% = iLongTroncon - iNbCarEnTrop If iLongRest + iTxtAff >= iLongTot Then iLongRest = iLongTot - iTxtAff - 1 bFin = True bAjoutCarSautDeLigne = False ' Pas besoin sur la dernière ligne End If sTxtTroncon = sTxtOrig.Substring(iTxtAff, iLongRest) sTxtTronconVerif = sTxtTroncon If bAjoutCarSautDeLigne Then sTxtTroncon &= sCarSautDeLigne Dim szTailleSubTxt = graphics.MeasureString(sTxtTroncon, lb.Font) Dim rSubTxtLarg0! = szTailleSubTxt.Width * rFact If rSubTxtLarg0 <= rLargeurDispo Then Exit Do iNbCarEnTrop += 1 If iNbCarEnTrop > iLongTroncon Then Exit Do Loop While True lb.Items.Add(sTxtTroncon) sTxtFinVerif &= sTxtTronconVerif iIndexTxtLb += 1 iTxtAff += iLongTroncon - iNbCarEnTrop iNumTroncon += 1 If bFin OrElse sTxtFinVerif.Length >= iLongTot Then Exit Do Loop While True lb.SelectedIndex = iIndexTxtLb - 1 If sTxtOrig <> sTxtFinVerif Then If bDebug Then Stop End If Else Fin: lb.Items.Add(sTxtOrig) ' Pour sélectionner le dernier texte ajouté dans la listBox, il suffit ' de compter les lignes ajoutées lb.SelectedIndex = iIndexTxtLb iIndexTxtLb += 1 End If End Sub Public Function sLireListBox$(lb As ListBox) Dim sb As New System.Text.StringBuilder For Each sTxt As String In lb.Items sb.AppendLine(sTxt) Next Dim sTxtFinal$ = sb.ToString Dim sTxt2$ = sTxtFinal.Replace(sCarSautDeLigne & vbCrLf, "") Return sTxt2 End Function Public Sub RemplirListBoxAuHasard(lb As ListBox, lst As List(Of String)) Dim iNbElements% = lst.Count Dim lstIndex As New List(Of Integer) Dim lstRnd As New List(Of String) For i As Integer = 0 To iNbElements - 1 Recom: Dim iNumElement% = iRandomiser(0, iNbElements - 1) If lstIndex.Contains(iNumElement) Then GoTo Recom lstIndex.Add(iNumElement) lstRnd.Add(lst(iNumElement)) Next lb.Items.Clear() For Each sPref In lstRnd lb.Items.Add(sPref) Next End Sub Public Sub VBMessageBox(sMsg$) MsgBox(sMsg, MsgBoxStyle.Exclamation, m_sTitreMsg) End Sub End Module clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Imports System.IO Public Class clsTickEventArgs : Inherits EventArgs ' Classe pour l'événement Tick : avancement d'une unité de temps : TIC-TAC ' utile pour mettre à jour l'heure en cours, ou pour scruter une annulation Public Sub New() End Sub End Class Public Class clsMsgEventArgs : Inherits EventArgs ' Classe pour l'événement Message Private m_sMsg$ = "" 'Nothing Public Sub New(sMsg$) 'If sMsg Is Nothing Then Throw New NullReferenceException If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsFECEventArgs : Inherits EventArgs ' Classe pour l'événement Fichier En Cours (FEC) Private m_iNumFichierEnCours% = 0 Public Sub New(iNumFichierEnCours%) Me.m_iNumFichierEnCours = iNumFichierEnCours End Sub Public ReadOnly Property iNumFichierEnCours%() Get Return Me.m_iNumFichierEnCours End Get End Property End Class Public Class clsFSIEventArgs : Inherits EventArgs ' Classe pour l'événement FileSystemInfo Private m_fsi As FileSystemInfo Public ReadOnly Property fsi() As FileSystemInfo Get Return Me.m_fsi End Get End Property Public Sub New(fsi As FileSystemInfo) Me.m_fsi = fsi End Sub End Class Public Class clsAvancementEventArgs : Inherits EventArgs ' Classe pour l'événement Avancement Private m_sMsg$ = "" Private m_lAvancement& = 0 Public Sub New(sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public Sub New(lAvancement&) Me.m_lAvancement = lAvancement End Sub Public Sub New(lAvancement&, sMsg$) Me.m_lAvancement = lAvancement If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property Public ReadOnly Property lAvancement&() Get Return Me.m_lAvancement End Get End Property End Class Public Class clsSablierEventArgs : Inherits EventArgs ' Classe pour l'événement Sablier Private m_bDesactiver As Boolean = False Public Sub New(bDesactiver As Boolean) Me.m_bDesactiver = bDesactiver End Sub Public ReadOnly Property bDesactiver() As Boolean Get Return Me.m_bDesactiver End Get End Property End Class Public Class clsMsgDelegue ' Classe de gestion des messages via des délégués 'Const bDoEvents As Boolean = False ' 16/10/2016 Pas de différence constatée ! Const bDoEvents As Boolean = True ' 04/02/2018 Il faut activer pour gérer l'annulation 'Private Delegate Sub GestEvTick(sender As Object, e As clsTickEventArgs) 'Public Event EvTick As GestEvTick Public Event EvTick As EventHandler(Of clsTickEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherMessage(sender As Object, e As clsMsgEventArgs) 'Public Event EvAfficherMessage As GestEvAfficherMessage Public Event EvAfficherMessage As EventHandler(Of clsMsgEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherFEC(sender As Object, e As clsFECEventArgs) 'Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC Public Event EvAfficherNumFichierEnCours As EventHandler(Of clsFECEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherFSI(sender As Object, e As clsFSIEventArgs) 'Public Event EvAfficherFSIEnCours As GestEvAfficherFSI Public Event EvAfficherFSIEnCours As EventHandler(Of clsFSIEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherAvancement(sender As Object, e As clsAvancementEventArgs) 'Public Event EvAfficherAvancement As GestEvAfficherAvancement Public Event EvAfficherAvancement As EventHandler(Of clsAvancementEventArgs) ' CA1003 'Private Delegate Sub GestEvSablier(sender As Object, e As clsSablierEventArgs) 'Public Event EvSablier As GestEvSablier Public Event EvSablier As EventHandler(Of clsSablierEventArgs) ' CA1003 Public m_bAnnuler As Boolean Public m_bErr As Boolean ' 21/03/2016 Public Sub New() End Sub Public Sub AfficherMsg(sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFichierEnCours(iNumFichierEnCours%) Dim e As New clsFECEventArgs(iNumFichierEnCours) RaiseEvent EvAfficherNumFichierEnCours(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFSIEnCours(fsi As FileSystemInfo) Dim e As New clsFSIEventArgs(fsi) RaiseEvent EvAfficherFSIEnCours(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherAvancement(lAvancement&, sMsg$) Dim e As New clsAvancementEventArgs(lAvancement, sMsg) RaiseEvent EvAfficherAvancement(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub Tick() Dim e As New clsTickEventArgs() RaiseEvent EvTick(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub Sablier(Optional bDesactiver As Boolean = False) Dim e As New clsSablierEventArgs(bDesactiver) RaiseEvent EvSablier(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub End Class clsDicoTri.vb ' Classe Dictionary triable Imports System.Runtime.Serialization <Serializable> _ Public Class DicoTri(Of TKey, TValue) : Inherits Dictionary(Of TKey, TValue) Sub New() End Sub Protected Sub New(info As SerializationInfo, context As StreamingContext) MyBase.New(info, context) End Sub Public Function Trier(Optional sOrdreTri$ = "") As TValue() ' Trier la Dico et renvoyer le tableau des éléments triés If String.IsNullOrEmpty(sOrdreTri) Then sOrdreTri = "" Dim iNbLignes% = Me.Count Dim arrayTvalue(iNbLignes - 1) As TValue Dim iNumLigne% = 0 For Each line As KeyValuePair(Of TKey, TValue) In Me arrayTvalue(iNumLigne) = line.Value iNumLigne += 1 Next ' Si pas de tri demandé, retourner simplement le tableau tel quel If sOrdreTri.Length = 0 Then Return arrayTvalue ' Tri des éléments Dim comp As New UniversalComparer(Of TValue)(sOrdreTri) Array.Sort(Of TValue)(arrayTvalue, comp) Return arrayTvalue End Function End Class modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... Public 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" ' 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 ' L'encodage UTF-8 est le meilleur compromis encombrement/capacité ' il permet l'encodage par exemple du grec, sans doubler la taille du texte '(mais le décodage est plus complexe en interne et les caractères ne s'affichent ' pas bien dans les certains logiciels utilitaires comme WinDiff, ' ni par exemple en csv pour Excel) ' http://fr.wikipedia.org/wiki/Unicode ' 65001 = Unicode UTF-8, 65000 = Unicode UTF-7 Public Const iEncodageUnicodeUTF8% = 65001 Public Const sEncodageISO_8859_1$ = "ISO-8859-1" #Region "Gestion des fichiers" 'Public Function bChoisirFichier(ByRef sCheminFichier$, sFiltre$, sExtDef$, _ ' sTitre$, Optional sInitDir$ = "", _ ' Optional bDoitExister As Boolean = True, _ ' Optional bMultiselect As Boolean = False) 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 = bMultiselect ' .Title = sTitre ' .ShowDialog() ' If .FileName <> "" Then sCheminFichier = .FileName : Return True ' Return False ' End With 'End Function Public Function bFichierExiste(sCheminFichier$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt Dim bFichierExiste0 As Boolean = IO.File.Exists(sCheminFichier) If Not bFichierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichier introuvable") Return bFichierExiste0 End Function Public Function bFichierExisteFiltre(sCheminFiltre$, sFiltre$, _ Optional 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 bFichierExisteFiltre0 As Boolean Dim di As New IO.DirectoryInfo(sCheminFiltre) If Not di.Exists Then bFichierExisteFiltre0 = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre0 = (iNbFichiers > 0) Fin: If Not bFichierExisteFiltre0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichiers introuvables") Return bFichierExisteFiltre0 End Function Public Function bFichierExisteFiltre2(sCheminFiltre$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If String.IsNullOrEmpty(sCheminFiltre) Then Return False 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) Return bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(sCheminDossier$, 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 Return 0 Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo Return fi.GetLength(0) End Function Public Function bTrouverFichier(sChemin$, sFiltre$, ByRef sCheminFichierTrouve$, _ Optional bPromptErr As Boolean = True) As Boolean ' Renvoyer le premier fichier correspondant au filtre sCheminFichierTrouve = "" If Not bDossierExiste(sChemin, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sChemin) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) sCheminFichierTrouve = sChemin & "\" & fi.Name Return True Next Return False End Function Public Function bCopierFichier(sCheminSrc$, sCheminDest$, _ Optional bPromptErr As Boolean = True, _ Optional bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Return False 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 AndAlso lTailleSrc = lTailleDest Then Return True ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Return False End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Return False 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Return False 'End If Try ' Cette fonction vient du kernel32.dll : rien à optimiser IO.File.Copy(sCheminSrc, sCheminDest) Return 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) Return False End Try End Function Public Function bCopierFichiers(sCheminSrc$, sFiltre$, sCheminDest$, _ Optional bPromptErr As Boolean = True) As Boolean ' Copier tous les fichiers correspondants au filtre dans le répertoire de destination If Not bDossierExiste(sCheminSrc, bPromptErr) Then Return False If Not bDossierExiste(sCheminDest, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sCheminSrc) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) Dim sFichier$ = fi.Name Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier If Not bCopierFichier(sSrc, sDest, bPromptErr) Then Return False Next Return True End Function Public Function bSupprimerFichier(sCheminFichier$, _ Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then Return True If Not bFichierAccessible(sCheminFichier, _ bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then Return False ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "Impossible de supprimer le fichier :" & vbLf & sCheminFichier, sCauseErrPoss) 'If bPromptErr Then _ ' MsgBox("Impossible de supprimer le fichier :" & vbLf & _ ' sCheminFichier & vbLf & _ ' sCauseErrPoss, MsgBoxStyle.Critical, m_sTitreMsg) Return False End Try End Function Public Function bSupprimerFichiersFiltres(sCheminDossier$, sFiltre$, _ Optional 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 Return True Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Return False Next sFichier Return True End Function Public Function bRenommerFichier(sSrc$, sDest$, _ Optional bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Return False 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, bPromptErr:=True) Then Return False Return True End If Else If Not bSupprimerFichier(sDest, bPromptErr:=True) Then Return False End If Try IO.File.Move(sSrc, sDest) Return 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) Return False End Try End Function Public Function bDeplacerFichiers2(sSrc$, 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 Return False Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Return False Return True End Function Public Function bDeplacerFichiers3(sCheminSrc$, sFiltre$, sCheminDest$, _ Optional bConserverDest As Boolean = True, _ Optional sExtDest$ = "", Optional 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 Return False Dim bChExt As Boolean = False If Not String.IsNullOrEmpty(sExtDest) Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim aFi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = aFi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(aFi(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 Return False Next i Return True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(sCheminFichier$, _ Optional bPrompt As Boolean = False, _ Optional bPromptFermer As Boolean = False, _ Optional bInexistOk As Boolean = False, _ Optional bPromptRetenter As Boolean = False, _ Optional bLectureSeule As Boolean = False, _ Optional bEcriture As Boolean = True) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) ' bEcriture = True par défaut (pour la rétrocompatibilité de la fct bFichierAccessible) ' Nouveau : Simple lecture : Mettre bEcriture = False ' On conserve l'option bLectureSeule pour alerter qu'un fichier doit être fermé ' par l'utilisateur (par exemple un classeur Excel ouvert) Retenter: If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas ' Et ne pas alerter non plus If Not bFichierExiste(sCheminFichier) Then Return True Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Return False End If 'Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Dim fs As IO.FileStream = Nothing Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read fs = New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() fs = Nothing Return 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\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( _ "Veuillez fermer S.V.P. le fichier :" & vbLf & _ sCheminFichier & sQuestion, msgbs, m_sTitreMsg) Else 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, m_sTitreMsg) End If End If Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try If reponse = MsgBoxResult.Retry Then GoTo Retenter Return False End Function ' CA2122 : désactivé à cause maintenant de CA2135 ! '<Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub ProposerOuvrirFichier(sCheminFichier$, _ Optional sInfo$ = "") If String.IsNullOrEmpty(sCheminFichier) Then Exit Sub 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 Not String.IsNullOrEmpty(sInfo) Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub ' CA2122 : désactivé à cause maintenant de CA2135 ! '<Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirAppliAssociee(sCheminFichier$, _ Optional bMax As Boolean = False, _ Optional bVerifierFichier As Boolean = True, _ Optional sArguments$ = "") 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 Using p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) p.StartInfo.Arguments = sArguments ' Il faut indiquer le chemin de l'exe si on n'utilise pas le shell 'p.StartInfo.UseShellExecute = False If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Using End Sub Public Function sFormaterTailleOctets$(lTailleOctets&, _ Optional bDetail As Boolean = False, _ Optional bSupprimerPt0 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 OrElse rNbMo >= 1 OrElse rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, _ bSupprimerPt0:=True) & " octets" End If End If sFormaterTailleOctets = sAffichage End Function Public Function sFormaterTailleKOctets$(lTailleOctets&, _ Optional bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier en Ko bien formatée dans une chaîne de caractère ' La méthode d'arrondie est la même que celle de l'explorateur de fichiers de Windows Dim rNbKo! = CSng(Math.Ceiling(lTailleOctets / 1024)) sFormaterTailleKOctets = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" End Function Public Function sFormaterNumerique$(rVal!, _ Optional bSupprimerPt0 As Boolean = True, _ Optional iNbDecimales% = 1) ' 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 ' NumberGroupSeparator : Séparateur des milliers, millions... ' NumberDecimalSeparator : Séparateur décimal ' NumberGroupSizes : 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) ' NumberDecimalDigits : 1 décimale de précision Dim nfi As New Globalization.NumberFormatInfo With { .NumberGroupSeparator = " ", .NumberDecimalSeparator = ".", .NumberGroupSizes = New Integer() {3, 3, 3}, .NumberDecimalDigits = iNbDecimales } Dim sFormatage$ = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormatage = sFormatage.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormatage = sFormatage.Replace(sb.ToString, "") End If End If Return sFormatage End Function Public Function sFormaterNumerique2$(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 ' Vérifier , et . : Dim sVal$ = rVal.ToString("n") Dim sVal2$ = sVal.Replace(",00", "").Replace(".00", "") ' n : numérique général Return sVal2 End Function Public Function sFormaterNumeriqueLong$(lVal&) ' 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 ' Vérifier , et . : Dim sVal$ = lVal.ToString("n") Dim sVal2$ = sVal.Replace(",00", "").Replace(".00", "") ' n : numérique général Return sVal2 End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(sCheminDossier$, _ Optional bPrompt As Boolean = True) As Boolean ' Vérifier si le dossier existe, et le créer sinon Dim di As New IO.DirectoryInfo(sCheminDossier) If di.Exists Then Return True Try di.Create() di = New IO.DirectoryInfo(sCheminDossier) Dim bExiste As Boolean = di.Exists Return bExiste Catch ex As Exception 'If bPrompt Then _ ' MsgBox("Impossible de créer le dossier :" & vbCrLf & _ ' sCheminDossier & vbCrLf & ex.Message, _ ' MsgBoxStyle.Critical, m_sTitreMsg) If bPrompt Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier", _ "Impossible de créer le dossier :" & vbCrLf & sCheminDossier) Return False End Try End Function Public Function bDossierExiste(sCheminDossier$, _ Optional 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() Dim bDossierExiste0 As Boolean = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Dossier introuvable") Return bDossierExiste0 End Function Public Function bRenommerDossier(sCheminDossierSrc$, sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Return False Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return 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) Return False End Try End Function Public Function bDeplacerDossier(sCheminDossierSrc$, sCheminDossierDest$, _ Optional 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 Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Return False Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return 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) Return False End Try End Function Public Function bSupprimerDossier(sCheminDossier$, _ Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then Return True 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) AndAlso i < 10 'TraiterMsgSysteme_DoEvents() 'Application.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, m_sTitreMsg) Return False End If Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) Return False End Try End Function Public Function sDossierParent$(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$(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$(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$(sCheminDossierOuFichier$, _ Optional 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 If String.IsNullOrEmpty(sCheminDossierOuFichier) Then Return "" 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$(sCheminFichier$, 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 If String.IsNullOrEmpty(sCheminFichier) Then Return "" If String.IsNullOrEmpty(sCheminReference) Then Return "" sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If String.IsNullOrEmpty(sChemin) Then Return "" If sChemin.EndsWith("\") Then Return sChemin.Substring(0, sChemin.Length - 1) Else Return sChemin End If End Function Public Function sEnleverSlashInitial$(sChemin$) ' Enlever le slash au début du chemin, le cas échéant If String.IsNullOrEmpty(sChemin) Then Return "" If sChemin.StartsWith("\") Then Return sChemin.Substring(1) Else Return sChemin End If End Function Public Function bCopierArbo(sSrc$, sDest$, _ ByRef bStatut As Boolean, ByRef sListeErr$, _ Optional 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) ' Voir aussi : Zeta Folder XCOPY By Uwe Keim ' A small class to perform basic XCOPY like operations from within C# ' http://www.codeproject.com/KB/recipes/ZetaFolderXCopy.aspx If String.IsNullOrEmpty(sSrc) Then Return False If String.IsNullOrEmpty(sDest) Then Return False 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) Return False 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, overwrite:=True) Catch ex As Exception If Not String.IsNullOrEmpty(sListeErrExcep) AndAlso _ sListeErrExcep.IndexOf(" " & sNomElements & " ") = iIndiceNulString 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 Return bStatut End Function Public Function sLecteurDossier$(sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function ' CA2122 : désactivé à cause maintenant de CA2135 ! '<System.Security.Permissions.SecurityPermissionAttribute( _ ' Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirDossier(sCheminDossier$) ' Ouvrir un dossier via l'explorateur de fichiers Using p As New Process ' Ne marche pas : 'Dim sArg$ = ", /e" ' Explorer le dossier 'p.StartInfo = New ProcessStartInfo(sCheminDossier, sArg) Dim startInfo As New ProcessStartInfo Dim sSysDir$ = Environment.GetFolderPath(Environment.SpecialFolder.System) Dim sWinDir$ = IO.Path.GetDirectoryName(sSysDir) startInfo.FileName = sWinDir & "\explorer.exe" startInfo.Arguments = sCheminDossier & ", /e" p.StartInfo = startInfo p.Start() End Using End Sub #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(sCheminFichier$, _ Optional bLectureSeule As Boolean = False, Optional bUnicodeUTF8 As Boolean = False) ' Lire et renvoyer le contenu d'un fichier Dim s$ = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return s Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, encodage) fs = Nothing 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 End Using Return sbContenu.ToString Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function sbLireFichier(sCheminFichier$, _ Optional bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier Dim sb As New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return sb Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) fs = Nothing Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sb.Append(vbCrLf) bDebut = True sb.Append(sLigne) Loop While True End Using Return sb Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function asLireFichier(sCheminFichier$, _ Optional bLectureSeule As Boolean = False, _ Optional bVerifierCrCrLf As Boolean = False, _ Optional bUnicodeUTF8 As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier Dim astr$() = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return astr Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If If bLectureSeule Then fs = New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encodage) fs = Nothing ' 23/04/2013 Optimisation du mode bLectureSeule ' On doit enlever les lignes vides dues au double séparateur CrLf 'Return sr.ReadToEnd.Split(vbCrLf.ToCharArray, StringSplitOptions.RemoveEmptyEntries) ' 24/04/2013 Conserver strictement le même comportement de sr.ReadLine() ' en RAM Dim fluxChaine As New clsFluxChaine(sr.ReadToEnd) Return fluxChaine.asLignes(bVerifierCrCrLf) 'Dim lst As New Collections.Generic.List(Of String) 'While Not sr.EndOfStream ' ' A line is defined as a sequence of characters followed by ' ' a line feed ("\n"), a carriage return ("\r"), or ' ' a carriage return immediately followed by a line feed ("\r\n"). ' ' http://msdn.microsoft.com/en-us/library/system.io.streamreader.readline.aspx ' lst.Add(sr.ReadLine()) 'End While 'Return lst.ToArray End Using Else Return IO.File.ReadAllLines(sCheminFichier, encodage) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function bListToHashSet(lst As List(Of String), ByRef hs As HashSet(Of String), _ Optional bPromptErr As Boolean = True) As Boolean ' Convertir une liste en HashSet en gérant les doublons ' Si on n'affiche pas les doublons, alors on dédoublonne automatiquement 'Try : Try Catch inutile, car le constructeur ne génère pas d'exception ' ' S'il n'y a pas de doublon, alors le constructeur idoine suffit ' hs = New HashSet(Of String)(lst) 'Catch ' S'il y a une exception, alors dédoublonner la liste 'End Try hs = New HashSet(Of String) For Each sLigne As String In lst If String.IsNullOrEmpty(sLigne) Then Continue For ' 09/06/2019 If hs.Contains(sLigne) Then ' Pour la chaîne vide, dédoublonner sans signalement If bPromptErr AndAlso Not String.IsNullOrEmpty(sLigne) Then MsgBox( "bListToHashSet : la liste contient au moins un doublon : " & sLigne, MsgBoxStyle.Critical, m_sTitreMsg) : Return False Continue For End If ' 28/04/2019 Suppression des commentaires de fin de ligne, le cas échéant Dim iPosCom% = sLigne.IndexOf("//") If iPosCom > iIndiceNulString Then Dim sLigneBrute$ = sLigne.Substring(0, iPosCom).Trim If sLigneBrute.Length = 0 Then Continue For sLigne = sLigneBrute End If hs.Add(sLigne) Next Return True End Function Public Function bEcrireFichier(sCheminFichier$, _ sbContenu As StringBuilder, _ Optional bEncodageDefaut As Boolean = False, _ Optional bEncodageISO_8859_1 As Boolean = False, _ Optional bEncodageUTF8 As Boolean = False, _ Optional bEncodageUTF16 As Boolean = False, _ Optional iEncodage% = 0, Optional sEncodage$ = "", _ Optional bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean ' 18/12/2017 bPromptErr:=True -> bPromptErr:=bPrompt If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPrompt) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then _ Throw New ArgumentNullException("sCheminFichier") If sbContenu Is Nothing Then Throw New ArgumentNullException("sbContenu") If String.IsNullOrEmpty(sEncodage) Then sEncodage = "" 'Dim sw As IO.StreamWriter = Nothing Try ' 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 ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUTF8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf bEncodageUTF16 Then ' 28/01/2013 encodage = Encoding.Unicode ' = UTF16 ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) sw.Write(sbContenu.ToString()) End Using 'sw.Close() Return 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, "bEcrireFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(sCheminFichier$, sContenu$, _ Optional bEncodageDefaut As Boolean = False, _ Optional bEncodageISO_8859_1 As Boolean = False, _ Optional bEncodageUFT8 As Boolean = False, _ Optional iEncodage% = 0, Optional sEncodage$ = "", _ Optional bPromptErr As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPromptErr) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then _ Throw New ArgumentNullException("sCheminFichier") If String.IsNullOrEmpty(sContenu) Then Throw New ArgumentNullException("sContenu") If String.IsNullOrEmpty(sEncodage) Then sEncodage = "" 'Dim sw As IO.StreamWriter = Nothing Try ' 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 ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) sw.Write(sContenu) End Using 'sw.Close() Return 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 bPromptErr Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, sContenu$, _ Optional bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then Throw New ArgumentNullException("sCheminFichier") If String.IsNullOrEmpty(sContenu) Then Throw New ArgumentNullException("sContenu") 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) End Using 'sw.Close() Return 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) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, _ sbContenu As StringBuilder) As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then Throw New ArgumentNullException("sCheminFichier") If sbContenu Is Nothing Then Throw New ArgumentNullException("sbContenu") 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) End Using 'sw.Close() Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(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 Return False Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Return False Return bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" Public Function asArgLigneCmd(sLigneCmd$, _ Optional bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande ' 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 ' Réutilisation de cette fonction pour parser les "" : ' -------------------------------------------------- ' Cette fonction ne respecte pas le nombre de colonne, elle parse seulement les "" correctement ' (on pourrait cependant faire une option pour conserver les colonnes vides) ' Cette fonction ne sait pas non plus parser correctement une seconde ouverture de "" entre ; ' tel que : xxx;"x""x";xxx ou "xxx";"x""x";"xxx" ' En dehors des guillemets, le séparateur est l'espace et non le ; ' -------------------------------------------------- Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If ' Parser les noms cours : facile 'asArgs = Split(Command, " ") Dim lstArgs As New List(Of String) ' 16/10/2016 Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim sFichier$, sSepar$ Dim sCmd$, iLongCmd%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean Dim iCarSuiv% = 1 sCmd = sLigneCmd iLongCmd = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Chaîne vide : "" Dim s2Car$ = Mid(sCmd, iDeb, 2) If s2Car = sGm & sGm Then bNomLong = True : sSepar = sGm iFin = iDeb + 1 GoTo Suite End If ' Si le premier caractère est un guillement, c'est un nom long Dim sCar$ = Mid(sCmd, iDeb, 1) 'Dim iCar% = Asc(sCar) ' Pour debug If sCar = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong AndAlso iDeb2 < iLongCmd Then iDeb2 += 1 ' Gestion chaîne vide iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' 16/10/2016 On tolère que un " peut remplacer un espace iCarSuiv = 1 Dim iFinGM% = InStr(iDeb2 + 1, sCmd, sGm) If iFinGM > 0 AndAlso iFin > 0 AndAlso iFinGM < iFin Then iFin = iFinGM : bNomLong = True : sSepar = sGm : iCarSuiv = 0 End If ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLongCmd + 1 sFichier = Mid(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim(sFichier) If sFichier.Length > 0 Then lstArgs.Add(sFichier) If bFin OrElse iFin = iLongCmd Then Exit Do Suite: iDeb = iFin + iCarSuiv ' 1 ' 16/10/2016 On tolère que un " peut remplacer un espace, plus besoin 'If bNomLong Then iDeb = iFin + 2 If iDeb > iLongCmd Then Exit Do ' 09/10/2014 Gestion chaîne vide Loop asArgs = lstArgs.ToArray() Const iCodeGuillemets% = 34 For iNumArg As Integer = 0 To UBound(asArgs) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide Dim iLong0% = Len(sArg) If iLong0 = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(sChaine$, _ Optional bLimit8Car As Boolean = False, _ Optional bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 correct 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 AndAlso iCode <= 90 Then bMaj = True If iCode >= 192 AndAlso 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 InStr("òóôõö", sCar) > 0 Then ' 08/05/2013 If bMaj Then sCarDest = "O" Else sCarDest = "o" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ç", sCar) > 0 Then ' 12/06/2015 If bMaj Then sCarDest = "C" Else sCarDest = "c" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If bConserverSignePlus AndAlso iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 AndAlso iCode <= 90) Then bOk = True If (iCode >= 97 AndAlso iCode <= 122) Then bOk = True If (iCode >= 48 AndAlso iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function Public Function sbEnleverAccents(sbChaine As StringBuilder, _ Optional bMinuscule As Boolean = True) As StringBuilder ' Enlever les accents ' 18/05/2018 If sbChaine.Length = 0 Then Return New StringBuilder Dim sTexte$ = sbChaine.ToString If bMinuscule Then sTexte = sTexte.ToLower Return sbRemoveDiacritics(sTexte) End Function Public Function sEnleverAccents$(sChaine$, Optional bMinuscule As Boolean = True) ' Enlever les accents If sChaine.Length = 0 Then Return "" ' 19/05/2018 Dim sTexteSansAccents$ = sRemoveDiacritics(sChaine) If bMinuscule Then Return sTexteSansAccents.ToLower Return sTexteSansAccents End Function Private Function sRemoveDiacritics$(sTexte$) Dim sb As StringBuilder = sbRemoveDiacritics(sTexte) Dim sTexteDest$ = sb.ToString Return sTexteDest End Function Private Function sbRemoveDiacritics(sTexte$) As StringBuilder ' How do I remove diacritics (accents) from a string in .NET? ' https://stackoverflow.com/questions/249087/how-do-i-remove-diacritics-accents-from-a-string-in-net 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormC) ' Conserve les accents Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormD) ' Ok 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormKC) ' Pareil que D 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormKD) ' Pareil que D Dim sb As New StringBuilder Const cChar_ae As Char = "æ"c Const cChar_oe As Char = "œ"c Const cChar_o As Char = "o"c Const cChar_e As Char = "e"c Const cChar_a As Char = "a"c Const cCharAE As Char = "Æ"c Const cCharOE As Char = "Œ"c Const cCharO As Char = "O"c Const cCharE As Char = "E"c Const cCharA As Char = "A"c Const cChar3P As Char = "…"c ' 15/09/2018 For Each c As Char In sNormalizedString Dim unicodeCategory As Globalization.UnicodeCategory = _ Globalization.CharUnicodeInfo.GetUnicodeCategory(c) If (unicodeCategory <> Globalization.UnicodeCategory.NonSpacingMark) Then 'sb.Append(c) ' Remplacement des caractères collées œ -> oe ' https://www.developpez.net/forums/d1160595/dotnet/langages/csharp/suppression-caracteres-speciaux-comparaison-chaines/ ' Non, conserver tous les caractères 'If "&$*@^#-+_".IndexOf(c) <> iIndiceNulString Then Continue For If c = cCharAE Then sb.Append(cCharA) sb.Append(cCharE) ElseIf c = cCharOE Then sb.Append(cCharO) sb.Append(cCharE) ElseIf c = cChar_ae Then sb.Append(cChar_a) sb.Append(cChar_e) ElseIf c = cChar_oe Then sb.Append(cChar_o) sb.Append(cChar_e) ElseIf c = cChar3P Then ' 15/09/2018 sb.Append("...") Else sb.Append(c) End If End If Next 'Dim sTexteSansAccent$ = sb.ToString ' Non, pas besoin de renormaliser 'Dim sTexteNormalise$ = sTexteSansAccent 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormC) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormD) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormKC) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormKD) Return sb End Function Public Function LireEncodage(sChemin$) As Encoding ' Déterminer l'encodage du fichier en analysant ses 1ers octets ' (Byte Order Mark, ou BOM). Par défaut l'encodage sera ASCII si on ne trouve pas ' Lecture de la BOM Dim bom As Byte() = New Byte(3) {} Using file As IO.FileStream = New IO.FileStream(sChemin, IO.FileMode.Open, _ IO.FileAccess.Read, IO.FileShare.ReadWrite) ' 05/01/2018 Need only read-only access, not write access file.Read(bom, 0, 4) End Using ' Analyse de la BOM If bom(0) = &H2B AndAlso bom(1) = &H2F AndAlso bom(2) = &H76 Then Return Encoding.UTF7 End If If bom(0) = &HEF AndAlso bom(1) = &HBB AndAlso bom(2) = &HBF Then Return Encoding.UTF8 End If ' 25/01/2019 If bom(0) = &H4E AndAlso bom(1) = &HC2 AndAlso bom(2) = &HB0 Then Return Encoding.UTF8 End If If bom(0) = &H22 AndAlso bom(1) = &H43 AndAlso bom(2) = &H6F AndAlso bom(3) = &H75 Then Return Encoding.UTF8 End If If bom(0) = 50 AndAlso bom(1) = 48 AndAlso bom(2) = 49 AndAlso bom(3) = 54 Then Return Encoding.UTF8 End If If bom(0) = 34 AndAlso bom(1) = 105 AndAlso bom(2) = 100 AndAlso bom(3) = 34 Then Return Encoding.UTF8 End If If bom(0) = &HFF AndAlso bom(1) = &HFE Then Return Encoding.Unicode End If ' UTF-16LE If bom(0) = &HFE AndAlso bom(1) = &HFF Then Return Encoding.BigEndianUnicode End If ' UTF-16BE If bom(0) = 0 AndAlso bom(1) = 0 AndAlso bom(2) = &HFE AndAlso bom(3) = &HFF Then Return Encoding.UTF32 End If Return Encoding.ASCII End Function #End Region #Region "Classe Flux Chaine" ' Equivalent de mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' mais pour une chaine : optimisation des flux Private Class clsFluxChaine Private m_iNumLigne% = 0 ' Debug Private m_sChaine$ Private m_iPos% = 0 Private Const c13 As Char = ChrW(13) ' vbCr Private Const c10 As Char = ChrW(10) ' vbLf Public Sub New(sChaine$) m_sChaine = sChaine End Sub Public Function asLignes(Optional bVerifierCrCrLf As Boolean = False) As String() Dim lst As New Collections.Generic.List(Of String) Dim iNumLigne2% = 0 Do Dim sLigne$ = StringReadLine(bVerifierCrCrLf) ' 05/02/2014 Ne pas ignorer les lignes vides, et poursuivre 'If String.IsNullOrEmpty(sLigne) Then Exit Do If IsNothing(sLigne) Then sLigne = "" lst.Add(sLigne) iNumLigne2 += 1 Loop While m_iPos < m_sChaine.Length ' 05/02/2014 'Loop While True Return lst.ToArray End Function Public Function StringReadLine$(Optional bVerifierCrCrLf As Boolean = False) If String.IsNullOrEmpty(m_sChaine) Then Return Nothing Dim iLong% = m_sChaine.Length Dim iNum% = m_iPos Do While iNum < iLong Dim ch As Char = m_sChaine.Chars(iNum) Select Case ch Case c13, c10 Dim str As String = m_sChaine.Substring(m_iPos, iNum - m_iPos) m_iPos = iNum + 1 If Not bVerifierCrCrLf Then ' 24/11/2013 If ch = c13 AndAlso m_iPos < iLong AndAlso _ m_sChaine.Chars(m_iPos) = c10 Then m_iPos += 1 Return str End If Dim chSuiv As Char '= m_sChaine.Chars(m_iPos) ' 17/09/2013 Maintenant qu'on fait +2, tester aussi ce cas If m_iPos < iLong Then chSuiv = m_sChaine.Chars(m_iPos) Dim chSuiv2 As Char If m_iPos < iLong - 1 Then chSuiv2 = m_sChaine.Chars(m_iPos + 1) ' 02/08/2013 Il peut arriver 13+13+10 !? If ch = c13 AndAlso m_iPos < iLong - 1 AndAlso _ chSuiv = c13 AndAlso chSuiv2 = c10 Then m_iPos += 2 ElseIf ch = c13 AndAlso m_iPos < iLong AndAlso chSuiv = c10 Then m_iPos += 1 End If 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str End Select iNum += 1 Loop If iNum > m_iPos Then Dim str2$ = m_sChaine.Substring(m_iPos, (iNum - m_iPos)) m_iPos = iNum 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str2 End If Return Nothing End Function End Class #End Region End Module UniversalComparer.vb Imports System.Collections.Generic Imports System.Reflection 'http://www.dotnet2themax.com/ShowContent.aspx?ID=05c3d0c3-ac44-4a20-92d9-16cdae040bc3 Public Class UniversalComparer(Of T) : Implements IComparer, IComparer(Of T) Private sortKeys() As SortKey Private m_bMsg As Boolean = False Private ReadOnly m_sTri$ = "" Public Sub New(sort As String) If String.IsNullOrEmpty(sort) Then sort = "" m_sTri = sort Dim type As Type = GetType(T) ' Split the list of properties. Dim props() As String = sort.Split(","c) ' Prepare the array that holds information on sort criteria. ReDim sortKeys(props.Length - 1) ' Parse the sort string. For i As Integer = 0 To props.Length - 1 ' Get the N-th member name. Dim memberName As String = props(i).Trim() If memberName.ToLower().EndsWith(" desc") Then ' Discard the DESC qualifier. sortKeys(i).Descending = True memberName = memberName.Remove(memberName.Length - 5).TrimEnd() End If ' Search for a field or a property with this name. sortKeys(i).FieldInfo = type.GetField(memberName) sortKeys(i).sMemberName = memberName If sortKeys(i).FieldInfo Is Nothing Then sortKeys(i).PropertyInfo = type.GetProperty(memberName) End If Next i End Sub Public Function Compare(x As Object, y As Object) As Integer _ Implements IComparer.Compare ' Implementation of IComparer.Compare Return Compare(CType(x, T), CType(y, T)) End Function Public Function Compare(x As T, y As T) As Integer _ Implements IComparer(Of T).Compare ' Implementation of IComparer(Of T).Compare ' Deal with simplest cases first. If x Is Nothing Then ' Two null objects are equal. If y Is Nothing Then Return 0 ' A null object is less than any non-null object. Return -1 ElseIf y Is Nothing Then ' Any non-null object is greater than a null object. Return 1 End If ' Iterate over all the sort keys. For i As Integer = 0 To sortKeys.Length - 1 Dim value1 As Object, value2 As Object Dim sortKey As SortKey = sortKeys(i) ' Read either the field or the property. If sortKey.FieldInfo IsNot Nothing Then value1 = sortKey.FieldInfo.GetValue(x) value2 = sortKey.FieldInfo.GetValue(y) Else If IsNothing(sortKey.PropertyInfo) Then If Not m_bMsg Then MsgBox( _ "Une clé de comparaison est introuvable : le champ indiqué n'existe pas" & vbLf & _ "ou bien n'est pas de portée publique !" & vbLf & _ GetType(T).ToString & " : " & sortKeys(i).sMemberName & " : " & m_sTri, _ MsgBoxStyle.Critical, "UniversalComparer:Compare") m_bMsg = True End If Return 0 End If value1 = sortKey.PropertyInfo.GetValue(x, Nothing) value2 = sortKey.PropertyInfo.GetValue(y, Nothing) End If Dim res As Integer If value1 Is Nothing AndAlso value2 Is Nothing Then ' Two null objects are equal. res = 0 ElseIf value1 Is Nothing Then ' A null object is always less than a non-null object. res = -1 ElseIf value2 Is Nothing Then ' Any object is greater than a null object. res = 1 Else ' Compare the two values, assuming that they support IComparable. res = DirectCast(value1, IComparable).CompareTo(value2) End If ' If values are different, return this value to caller. If res <> 0 Then ' Negate it if sort direction is descending. If sortKey.Descending Then res = -res Return res End If Next i ' If we get here the two objects are equal. Return 0 End Function Private Structure SortKey ' Nested type to store detail on sort keys Public FieldInfo As FieldInfo Public PropertyInfo As PropertyInfo ' True if sort is descending. Public Descending As Boolean Public sMemberName$ End Structure End Class GlobalSuppressions.vb ' This file is used by Code Analysis to maintain SuppressMessage ' attributes that are applied to this project. ' Project-level suppressions either have no target or are given ' a specific target and scoped to a namespace, type, member, etc. ' Ce fichier est utilisé par l'analyse du code pour tenir à jour les attributs ' SuppressMessage appliqués à ce projet. ' Les suppressions au niveau du projet n'ont pas de cible ou ont ' une cible spécifique et comme portée un espace de noms, un type, un membre etc. ' ' Pour ajouter une suppression à ce fichier, cliquez avec le bouton droit sur le message dans les résultats de l'analyse du code ', pointez sur "Supprimer les messages", puis cliquez sur ' "Dans le fichier de suppression". ' Vous n'avez pas besoin d'ajouter des suppressions à ce fichier manuellement. <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1062:Valider les arguments de méthodes publiques", MessageId:="1", Scope:="member", Target:="Logotron.modBase+clsBase.#bLireSegment(System.Int32,Logotron.modBase+clsSegmentBase&)")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1062:Valider les arguments de méthodes publiques", MessageId:="3", Scope:="member", Target:="Logotron.modUtilFichier.#bCopierArbo(System.String,System.String,System.Boolean&,System.String&,System.String)")>