VBTextFinder v1.2.2.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmVBTxtFnd.vb 2.1 - Private Function bChercherDico 2.2 - Private Sub Activer 2.3 - Private Sub AfficherDescriptionDocIndex 2.4 - Private Sub AfficherHtml 2.5 - Private Sub AfficherMessage 2.6 - Private Sub AfficherMotsCompatEnCoursDeFrappe 2.7 - Private Sub AfficherMsgDelegue 2.8 - Private Sub AfficherMsgDelegue 2.9 - Private Sub AjouterDocument 2.10 - Private Sub AjouterMenuCtx 2.11 - Private Sub AjouterMenuCtxIndexer 2.12 - Private Sub BasculerFiltreIndexationFichiers 2.13 - Private Sub Chercher 2.14 - Private Sub ChercherDirect 2.15 - Private Sub chkAccents_CheckedChanged 2.16 - Private Sub chkAccents_Click 2.17 - Private Sub chkAfficherInfoDoc_Click 2.18 - Private Sub chkAfficherInfoResultat_Click 2.19 - Private Sub chkAfficherNumOccur_Click 2.20 - Private Sub chkAfficherNumParag_Click 2.21 - Private Sub chkAfficherNumPhrase_Click 2.22 - Private Sub chkAfficherTiret_Click 2.23 - Private Sub chkChapitrage_CheckedChanged 2.24 - Private Sub chkMotsDico_Click 2.25 - Private Sub chkNumerotationGlobale_Click 2.26 - Private Sub chkUnicode_CheckedChanged 2.27 - Private Sub chkUnicode_Click 2.28 - Private Sub CmdAjouterDocument_Click 2.29 - Private Sub cmdAjouterMenuCtx_Click 2.30 - Private Sub CmdChercher_Click 2.31 - Private Sub CmdChoisirFichierDoc_Click 2.32 - Private Sub cmdEnleverMenuCtx_Click 2.33 - Private Sub cmdExporterTxt_Click 2.34 - Private Sub cmdGlossaire_Click 2.35 - Private Sub CmdInterrompre_Click 2.36 - Private Sub cmdListeDoc_Click 2.37 - Private Sub cmdListeDocHtml_Click 2.38 - Private Sub cmdNavigExterne_Click 2.39 - Private Sub CreerDocIndex 2.40 - Private Sub EnleverMenuCtx 2.41 - Private Sub EnleverMenuCtxIndexer 2.42 - Private Sub frmVBTextFinder_Activated 2.43 - Private Sub frmVBTextFinder_Closing 2.44 - Private Sub frmVBTextFinder_Load 2.45 - Private Sub HyperTexte 2.46 - Private Sub InitialiserFenetre 2.47 - Private Sub lbCodesLangues_Click 2.48 - Private Sub ListerDocumentsIndexes 2.49 - Private Sub LstTypeAffichResult_Click 2.50 - Private Sub LstTypeIndex_Click 2.51 - Private Sub LstTypeIndex_DoubleClick 2.52 - Private Sub Sablier 2.53 - Private Sub SauverConfig 2.54 - Private Sub ScrollParag 2.55 - Private Sub ScrollParagPredef 2.56 - Private Sub tcOnglets_SelectedIndexChanged 2.57 - Private Sub TitrerAppli 2.58 - Private Sub TxtCheminDocument_DoubleClick 2.59 - Private Sub TxtCheminDocument_TextChanged 2.60 - Private Sub TxtMot_KeyDown 2.61 - Private Sub TxtMot_TextChanged 2.62 - Private Sub TxtResultat_DoubleClick 2.63 - Private Sub TxtResultat_MouseUp 2.64 - Private Sub VerifierActivationCmdIndexer 2.65 - Private Sub VerifierDico 2.66 - Private Sub VerifierMenuCtx 2.67 - Private Sub VerifierOperationsPossibles 2.68 - Private Sub vsbZoomParag_ValueChanged 2.69 - Private Sub wbResultat_DocumentCompleted 3 - clsVBTxtFnd.vb 3.1 - Private Function bAjouterDocument 3.2 - Private Function bCleExiste 3.3 - Private Function bContientSeparateurPhrases 3.4 - Private Function bCreerDocIndexIntern 3.5 - Private Function bIndexerDocument 3.6 - Private Function bIndexerDocumentInterne 3.7 - Private Function bInitDico 3.8 - Private Function bInitMotsCourants 3.9 - Private Function bInterruption 3.10 - Private Function bLireCleBRWinMerge 3.11 - Private Function bMotDico 3.12 - Private Function bSauvegarderIndex 3.13 - Private Function bSeparateurPhrases 3.14 - Private Function bValiderSauvegardeTmp 3.15 - Private Function iLireNumParagGPhrase% 3.16 - Private Function ListToListSansAccent 3.17 - Private Function MarquerOccurrencesHtml 3.18 - Private Function sInfoDoc$ 3.19 - Private Function sInfoParag$ 3.20 - Private Function sLireCleDocPhrase$ 3.21 - Private Function sLireCodeDoc$ 3.22 - Private Function sLirePhrase$ 3.23 - Private Sub AfficherMessage 3.24 - Private Sub AfficherResultats 3.25 - Private Sub AjouterMotDejaTrouve 3.26 - Private Sub CreerDocIndexSimple 3.27 - Private Sub EcrireChapitre 3.28 - Private Sub EcrireListeDocumentsIndexesIni 3.29 - Private Sub ExtraireCitations 3.30 - Private Sub GestionChapitrage 3.31 - Private Sub LireDoc 3.32 - Private Sub NoterPositionCurseur2 3.33 - Private Sub ParserChapitrage 3.34 - Private Sub RegenererDocs 3.35 - Private Sub ReinitDicoAccentOuPas 3.36 - Private Sub RestaurerPositionCurseur 3.37 - Private Sub TestBiGrammesP1 3.38 - Private Sub TestBiGrammesP2 3.39 - Public Delegate Sub GestEvAfficherMessage 3.40 - Public Function bCleDocExiste 3.41 - Public Function bConvertirDocEnTxt 3.42 - Public Function bHyperTexte 3.43 - Public Function bIndexerDocuments 3.44 - Public Function bLireIndex 3.45 - Public Function bMotExiste 3.46 - Public Function bQuitter 3.47 - Public Function bSeparateurMots 3.48 - Public Function iNbDocumentsIndexes% 3.49 - Public Function sCleDocDefaut$ 3.50 - Public Sub AfficherFichierIni 3.51 - Public Sub AnalyseAccents 3.52 - Public Sub ChercherOccurrencesMot 3.53 - Public Sub ChercherOccurrencesMots 3.54 - Public Sub ComparerIndexSimple 3.55 - Public Sub CreerDocIndex 3.56 - Public Sub CreerDocIndexCitations 3.57 - Public Sub CreerDocIndexEspInsec 3.58 - Public Sub CreerDocIndexMajuscules 3.59 - Public Sub Initialiser 3.60 - Public Sub InitNouvelleRecherche 3.61 - Public Sub Interrompre 3.62 - Public Sub LireListeDocumentsIndexesIni 3.63 - Public Sub ListerDocumentsIndexes 3.64 - Public Sub NoterPositionCurseur 3.65 - Public Sub ReinitDico 3.66 - Public Sub Sablier 4 - modConfig.vb 5 - modStruct.vb 5.1 - Public Function iLireNumPhrase% 5.2 - Public Function iNbPhrases% 5.3 - Public Sub AjouterNumPhrase3 5.4 - Public Sub RedimPhrases 6 - modUtilVBTF.vb 6.1 - Public Function bCarNumerique 6.2 - Public Function bEcrireChaine 6.3 - Public Function bLireChaine 6.4 - Public Function sRognerDernierCar$ 6.5 - Public FunctionIndexOfUppercase% 6.6 - Public FunctionVBSplit 7 - modUtilLT.vb 7.1 - Public Function bConvertirDocEnTxt2 8 - clsHebOffice.vb 8.1 - Public Function bMonInstanceOuverte 8.2 - Public Function bOuvert 8.3 - Public Overloads Shared Function bOuvert 8.4 - Public Overloads Shared Function bOuvert 8.5 - Public Shared Function bOuvert 8.6 - Public Shared Sub LibererObjetCom 8.7 - Public Shared Sub LibererObjetCom 8.8 - Public Sub Fermer 8.9 - Public Sub New 8.10 - Public Sub New 8.11 - Public Sub New 8.12 - Public Sub New 8.13 - Public Sub Quitter 8.14 - Public Sub Quitter 9 - modUtil.vb 9.1 - Public FunctioniConv% 9.2 - Public Sub AfficherMsgErreur 9.3 - Public Sub AfficherMsgErreur2 9.4 - Public Sub CopierPressePapier 9.5 - Public Sub TraiterMsgSysteme_DoEvents 10 - modUtilFichier.vb 10.1 - Private Function sbRemoveDiacritics 10.2 - Private Function sRemoveDiacritics$ 10.3 - Public Function asArgLigneCmd 10.4 - Public Function asLignes 10.5 - Public Function asLireFichier 10.6 - Public Function bAjouterFichier 10.7 - Public Function bAjouterFichier 10.8 - Public Function bCopierArbo 10.9 - Public Function bCopierFichier 10.10 - Public Function bCopierFichiers 10.11 - Public Function bDeplacerDossier 10.12 - Public Function bDeplacerFichiers2 10.13 - Public Function bDeplacerFichiers3 10.14 - Public Function bDossierExiste 10.15 - Public Function bEcrireFichier 10.16 - Public Function bEcrireFichier 10.17 - Public Function bFichierExiste 10.18 - Public Function bFichierExisteFiltre 10.19 - Public Function bFichierExisteFiltre2 10.20 - Public Function bListToHashSet 10.21 - Public Function bReencoder 10.22 - Public Function bRenommerDossier 10.23 - Public Function bRenommerFichier 10.24 - Public Function bSupprimerDossier 10.25 - Public Function bSupprimerFichier 10.26 - Public Function bSupprimerFichiersFiltres 10.27 - Public Function bTrouverFichier 10.28 - Public Function bVerifierCreerDossier 10.29 - Public Function iNbFichiersFiltres% 10.30 - Public Function LireEncodage 10.31 - Public Function sbEnleverAccents 10.32 - Public Function sbLireFichier 10.33 - Public Function sCheminRelatif$ 10.34 - Public Function sConvNomDos$ 10.35 - Public Function sDossierParent$ 10.36 - Public Function sEnleverAccents$ 10.37 - Public Function sEnleverSlashFinal$ 10.38 - Public Function sEnleverSlashInitial$ 10.39 - Public Function sExtraireChemin$ 10.40 - Public Function sFormaterNumerique$ 10.41 - Public Function sFormaterNumerique2$ 10.42 - Public Function sFormaterNumeriqueLong$ 10.43 - Public Function sFormaterTailleKOctets$ 10.44 - Public Function sFormaterTailleOctets$ 10.45 - Public Function sLecteurDossier$ 10.46 - Public Function sLireFichier$ 10.47 - Public Function sNomDossierFinal$ 10.48 - Public Function sNomDossierParent$ 10.49 - Public Function StringReadLine$ 10.50 - Public FunctionbFichierAccessible 10.51 - Public Sub New 10.52 - Public SubOuvrirAppliAssociee 10.53 - Public SubOuvrirDossier 10.54 - Public SubProposerOuvrirFichier 11 - modUtilReg.vb 11.1 - Public Function asListeSousClesCU 11.2 - Public Function bAjouterMenuContextuel 11.3 - Public Function bAjouterTypeFichier 11.4 - Public Function bCleRegistreCRExiste 11.5 - Public Function bCleRegistreCRExiste 11.6 - Public Function bCleRegistreCUExiste 11.7 - Public Function bCleRegistreLMExiste AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("VBTextFinder")> <Assembly: AssemblyDescription( _ "VBTextFinder : un moteur de recherche de mot dans son contexte" & _ " par patrice.dargenton@free.fr Documentation : VBTextFinder.html")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("VBTextFinder")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2020")> <Assembly: AssemblyTrademark("VBTextFinder")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("1.2.2.*")> frmVBTxtFnd.vb ' VBTextFinder : un moteur de recherche de mot dans son contexte ' -------------------------------------------------------------- ' https://codes-sources.commentcamarche.net/source/46695 ' Documentation : VBTextFinder.html : ' http://patrice.dargenton.free.fr/CodesSources/VBTextFinder.html ' http://patrice.dargenton.free.fr/CodesSources/VBTextFinder.vbproj.html ' Version 1.22 du 03/05/2020 Détection de la présence ou l'absence de caractères Unicodes ' Version 1.21 du 05/05/2018 Correction du bug Mémoire insuffisante (doc2Txt) ' Version 1.20 du 20/11/2016 Gestion des espaces insécables ' Version 1.19 du 29/05/2015 Indexer tout type de fichier, pas seulement .txt, .doc ou .htm? ' Version 1.18 du 28/06/2014 Glossaire des mots hors dictionnaire de Word ' Version 1.17 du 04/05/2014 Passage en VB 2010 et DotNet 4.0 ' Version 1.16 du 12/09/2010 ' Version 1.15 du 25/08/2010 ' Version 1.14 du 25/04/2010 ' Version 1.13 du 03/01/2010 ' Version 1.12 du 01/11/2009 ' Version 1.11 du 20/09/2009 ' Version 1.10 du 06/09/2009 ' Version 1.04 du 07/06/2008 ' Version 1.03 du 18/05/2008 ' Par Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' -------------------------------------------------------------- ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ ' Fichier frmVBTxtFnd.vb : ' ---------------------- Public Class frmVBTextFinder ': Inherits Form : cf. classe partielle .Designer.vb #Region "Déclarations" Private Const iOngletRechercher% = 0 ' 0 : 1er onglet Private Const iOngletWeb% = 1 Private Const iOngletIndexer% = 2 Private Const iOngletOutils% = 3 Private Const iOngletConfig% = 4 ' Menus contextuels Private Const sMenuCtx_TypeFichierTxt$ = "txtfile" Private Const sMenuCtx_TypeFichierDoc$ = "Word.Document.8" ' Word 2003 (Ne marche pas si on ne met que Word.Document) 'Private Const sMenuCtx_TypeFichierHtml$ = "htmlfile" ' Ne fonctionne plus ? Private Const sMenuCtx_TypeFichierTous$ = "*" ' Tous les fichiers 28/06/2014 Private Const sMenuCtx_TypeDossier$ = "Directory" ' Il vaut mieux indiquer VBTextFinder devant Indexer pour rappeler quel logiciel ajoute cette clé Private Const sMenuCtx_CleCmdIndexer$ = "VBTextFinder.Indexer" Private Const sMenuCtx_CleCmdIndexerDescription$ = "Indexer pour une recherche (VBTF)" ' Lorsque l'on créé un nouveau type de fichier, il faut d'abord placer un pointeur ' de l'extension vers le type : .idx -> VBTextFinder ' Attention : on suppose qu'aucun autre logiciel n'utilise cette clé (ce qui est vrai en standard) Private Const sMenuCtx_ExtFichierIdx$ = ".idx" ' Doit pointer vers sMenuCtx_TypeFichierIdx ' Description qui apparait dans l'explorateur à la place du nom générique ' fichier IDX Private Const sMenuCtx_ExtFichierIdxDescription$ = "index VBTextFinder" Private Const sMenuCtx_TypeFichierIdx$ = "VBTextFinder" Private Const sMenuCtx_TypeFichierIdxDescription$ = _ "Index VBTextFinder (fichier .idx)" Private Const sMenuCtx_CleCmdIndexOuvrir$ = "Ouvrir" Private Const sMenuCtx_CleCmdIndexOuvrirDescription$ = "Ouvrir avec VBTextFinder" ' Objet moteur de recherche : c'est l'objet principal ' dont ce formulaire est l'interface Private oVBTxtFnd As New clsVBTextFinder Private WithEvents m_msgDelegue As New clsMsgDelegue ' Initialiser seulement la première fois que la fenêtre est prête Private m_bInit As Boolean 'Private m_bQuitter As Boolean 'Private bClickParag As Boolean Private m_bSauverOption_bTexteUnicode As Boolean = True Private m_bSauverOption_bIndexerAccents As Boolean = True Private m_bSauverOption_bIndexerChapitrage As Boolean = True Private sCheminHtmlTmp$ = Application.StartupPath & "\VBTextFinderTmp.html" Private sCheminTxtTmp$ = Application.StartupPath & "\VBTextFinderTmp.txt" #End Region #Region "Initialisations" Private Sub TitrerAppli() 'Me.Text &= " - Version " & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sVersionAppli$ = My.Application.Info.Version.Major & _ "." & My.Application.Info.Version.Minor & _ My.Application.Info.Version.Build Dim sTxt$ = "VBTextFinder : un moteur de recherche de mot dans son contexte" & _ " - Version " & sVersionAppli & " (" & sDateVersionAppli & ")" If Me.chkUnicode.Checked Then sTxt &= " - Unicode" If Me.chkAccents.Checked Then sTxt &= " - Accents" If bDebug Then sTxt &= " - Debug" Me.Text = sTxt End Sub Private Sub chkChapitrage_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkChapitrage.CheckedChanged Me.oVBTxtFnd.m_bIndexerChapitre = Me.chkChapitrage.Checked Me.chkAfficherChapitreIndex.Enabled = Me.chkChapitrage.Checked End Sub Private Sub chkUnicode_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkUnicode.CheckedChanged TitrerAppli() Me.oVBTxtFnd.m_bOptionTexteUnicode = Me.chkUnicode.Checked End Sub Private Sub chkAccents_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkAccents.CheckedChanged TitrerAppli() Me.oVBTxtFnd.IndexerAccents = Me.chkAccents.Checked End Sub Private Sub chkUnicode_Click(sender As Object, e As EventArgs) _ Handles chkUnicode.Click ' Si on clique alors sauver l'option m_bSauverOption_bTexteUnicode = True End Sub Private Sub chkAccents_Click(sender As Object, e As EventArgs) _ Handles chkAccents.Click ' Si on clique alors sauver l'option m_bSauverOption_bIndexerAccents = True End Sub Private Sub frmVBTextFinder_Load(sender As Object, e As EventArgs) _ Handles MyBase.Load ' 04/05/2014 modUtilFichier peut maintenant être compilé dans une dll DefinirTitreApplication(sTitreMsg) Dim iTypeIndexSelect% = My.Settings.iIndexType Me.oVBTxtFnd.IndexerAccents = My.Settings.bIndexerAccents Me.oVBTxtFnd.m_bOptionTexteUnicode = My.Settings.bTexteUnicode Me.oVBTxtFnd.m_bIndexerChapitre = Me.chkChapitrage.Checked 'Me.oVBTxtFnd.m_sChapitrage = Me.tbChapitrage.Text Me.oVBTxtFnd.Initialiser(Me.m_msgDelegue, Me.LstTypeAffichResult, _ Me.lstTypeIndex, iTypeIndexSelect) Me.tbChapitrage.Text = Me.oVBTxtFnd.m_sChapitrage TitrerAppli() Me.wbResultat.Navigate("") End Sub Private Sub frmVBTextFinder_Activated(eventSender As Object, _ eventArgs As EventArgs) Handles MyBase.Activated Activer() End Sub Private Sub frmVBTextFinder_Closing(sender As Object, _ e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing If Not Me.oVBTxtFnd.bQuitter() Then e.Cancel = True : Exit Sub SauverConfig(Me.Location, Me.Size, Me.WindowState) 'm_bQuitter = True End Sub ' Note : l'appel à InitialiserFenetre() se trouve dans la fonction New() ' cf. frmVBTxtFnd.Designer.vb Private Sub InitialiserFenetre() ' Reprendre la taille et la position précédente de la fenêtre ' Le fichier sera lu ici : '\Documents and Settings\<utilisateur>\Local Settings\Application Data\ ' ORS_Production\VBTextFinder.exe_Url_xxx...xxx\1.1.x.xxxxx\user.config ' Positionnement de la fenêtre par le code : mode manuel Me.StartPosition = FormStartPosition.Manual ' Fixer la position et la taille de la feuille sauvées dans le fichier .exe.config Dim x% = My.Settings.frm_X Dim y% = My.Settings.frm_Y Dim w% = My.Settings.frm_Larg Dim h% = My.Settings.frm_Haut Me.Location = New Drawing.Point(x, y) Me.Size = New Size(w, h) 'If My.Settings.frm_EtatFenetre = 2 Then Me.WindowState = FormWindowState.Maximized Select Case My.Settings.frm_EtatFenetre Case 0 : Me.WindowState = FormWindowState.Normal Case 1 : Me.WindowState = FormWindowState.Minimized Case 2 : Me.WindowState = FormWindowState.Maximized End Select If bDebug Then Me.StartPosition = FormStartPosition.CenterScreen Me.chkMotsCourants.Checked = My.Settings.bIndexAvecMotsCourant Me.chkMotsDico.Checked = My.Settings.bIndexAvecMotsDico Me.chkNumeriques.Checked = My.Settings.bIndexAvecNumeriques Me.tbCodeLangue.Text = My.Settings.sCodeLangueIndex Me.tbCodesLangues.Text = My.Settings.sListeCodesLanguesIndex Me.lbCodesLangues.DataSource = My.Settings.sListeCodesLanguesIndex.Split(";".ToCharArray) For i As Integer = 0 To Me.lbCodesLangues.Items.Count - 1 Me.lbCodesLangues.SetSelected(i, False) If i > Me.lbCodesLangues.Items.Count Then Exit For If Me.lbCodesLangues.Items(i).ToString <> Me.tbCodeLangue.Text Then Continue For Me.lbCodesLangues.SetSelected(i, True) Exit For Next Me.chkListeMots.Checked = My.Settings.bIndexListeMots Me.mtbNbMotsCles.Text = My.Settings.NbMotsCles.ToString Me.chkUnicode.Checked = My.Settings.bTexteUnicode Me.chkAccents.Checked = My.Settings.bIndexerAccents Me.chkAfficherInfoResultat.Checked = My.Settings.bAfficherInfoResultat Me.chkAfficherInfoDoc.Checked = My.Settings.bAfficherInfoDoc Me.chkNumerotationGlobale.Checked = My.Settings.bNumerotationGlobale Me.chkAfficherNumParag.Checked = My.Settings.bAfficherNumParag Me.chkAfficherNumPhrase.Checked = My.Settings.bAfficherNumPhrase Me.chkAfficherNumOccur.Checked = My.Settings.bAfficherNumOccur Me.chkAfficherTiret.Checked = My.Settings.bAfficherTiret Me.chkHtmlGras.Checked = My.Settings.bOccurrencesGras Me.chkHtmlCouleurs.Checked = My.Settings.bOccurrencesCouleur Me.tbCouleursHtml.Text = My.Settings.sCouleursHtml Me.chkChapitrage.Checked = My.Settings.bIndexerChapitre 'Me.tbChapitrage.Text = My.Settings.sChapitrage If Not Me.chkChapitrage.Checked Then Me.chkAfficherChapitreIndex.Checked = False Me.chkAfficherChapitreIndex.Enabled = False Else Me.chkAfficherChapitreIndex.Enabled = True Me.chkAfficherChapitreIndex.Checked = My.Settings.bAfficherChapitreIndex End If Me.chkUnicodeVerif.Checked = My.Settings.bVerifierUnicode ' 02/06/2019 End Sub Private Sub SauverConfig( _ pt As Point, _ sz As Size, _ Optional ws As Windows.Forms.FormWindowState = FormWindowState.Normal, _ Optional bVerifierComposants As Boolean = True) ' Sauver la configuration (emplacement de la fenêtre) dans le fichier .exe.config ' Le fichier sera sauvé ici : '\Documents and Settings\<utilisateur>\Local Settings\Application Data\ ' ORS_Production\VBTextFinder.exe_Url_xxx...xxx\1.1.x.xxxxx\user.config If ws = FormWindowState.Normal Then My.Settings.frm_X = pt.X My.Settings.frm_Y = pt.Y My.Settings.frm_Larg = sz.Width My.Settings.frm_Haut = sz.Height My.Settings.frm_EtatFenetre = 0 ElseIf ws = FormWindowState.Minimized Then My.Settings.frm_EtatFenetre = 1 ElseIf ws = FormWindowState.Maximized Then My.Settings.frm_EtatFenetre = 2 End If My.Settings.bIndexAvecMotsCourant = Me.chkMotsCourants.Checked My.Settings.bIndexAvecMotsDico = Me.chkMotsDico.Checked My.Settings.bIndexAvecNumeriques = Me.chkNumeriques.Checked My.Settings.sCodeLangueIndex = Me.tbCodeLangue.Text My.Settings.sListeCodesLanguesIndex = Me.tbCodesLangues.Text My.Settings.bIndexListeMots = Me.chkListeMots.Checked Integer.TryParse(Me.mtbNbMotsCles.Text, My.Settings.NbMotsCles) My.Settings.iIndexType = Me.lstTypeIndex.SelectedIndex My.Settings.bAfficherInfoResultat = Me.chkAfficherInfoResultat.Checked My.Settings.bAfficherInfoDoc = Me.chkAfficherInfoDoc.Checked My.Settings.bNumerotationGlobale = Me.chkNumerotationGlobale.Checked My.Settings.bAfficherNumParag = Me.chkAfficherNumParag.Checked My.Settings.bAfficherNumPhrase = Me.chkAfficherNumPhrase.Checked My.Settings.bAfficherNumOccur = Me.chkAfficherNumOccur.Checked My.Settings.bAfficherTiret = Me.chkAfficherTiret.Checked If m_bSauverOption_bTexteUnicode Then _ My.Settings.bTexteUnicode = Me.chkUnicode.Checked If m_bSauverOption_bIndexerAccents Then _ My.Settings.bIndexerAccents = Me.chkAccents.Checked My.Settings.bOccurrencesGras = Me.chkHtmlGras.Checked My.Settings.bOccurrencesCouleur = Me.chkHtmlCouleurs.Checked My.Settings.sCouleursHtml = Me.tbCouleursHtml.Text If m_bSauverOption_bIndexerChapitrage Then My.Settings.bIndexerChapitre = Me.chkChapitrage.Checked My.Settings.bAfficherChapitreIndex = Me.chkAfficherChapitreIndex.Checked End If 'My.Settings.sChapitrage = Me.tbChapitrage.Text My.Settings.bVerifierUnicode = Me.chkUnicodeVerif.Checked ' 02/06/2019 ' Si l'infrastructure de l'appli. est activée, l'appel peut être automatique ' (simple case à cocher) My.Settings.Save() End Sub Private Sub Activer() If m_bInit Then Exit Sub m_bInit = True VerifierMenuCtx() Me.CmdInterrompre.Enabled = False 'Me.TxtMot.Enabled = False Me.CmdChercher.Enabled = False Me.CmdAjouterDocument.Enabled = False Me.AfficherMessage("Initialisation en cours...") If bDebug Then 'Me.chkAccents.Checked = True 'Me.chkUnicode.Checked = True 'Me.oVBTxtFnd.m_bModeDirect = True 'Me.oVBTxtFnd.m_sCheminFichierTxtDirect = Application.StartupPath & "\Tmp\Test.doc" End If If Me.oVBTxtFnd.m_bModeDirect Then ' Test de conversion d'un fichier .doc en .txt : ' If True OrElse Me.oVBTxtFnd.m_bModeDirect Then 'Me.oVBTxtFnd.m_sCheminFichierTxtDirect = "D:\Tmp\Mon.doc" Me.TxtCheminDocument.Text = Me.oVBTxtFnd.m_sCheminFichierTxtDirect Application.DoEvents() ' Convertir le fichier en .txt si son extension ' est celle d'un document convertible (.doc, .html ou .htm) 'Dim bVerifierUnicode As Boolean = My.Settings.bVerifierUnicode Dim bVerifierUnicode As Boolean = Me.chkUnicodeVerif.Checked ' 01/06/2019 If Me.oVBTxtFnd.bConvertirDocEnTxt( _ Me.oVBTxtFnd.m_sCheminFichierTxtDirect, bVerifierUnicode, Me.oVBTxtFnd.m_bAuMoinsUnTxtUnicode, Me.oVBTxtFnd.m_bAvertAuMoinsUnTxtUnicode, Me.oVBTxtFnd.m_bInfoAuMoinsUnTxtNonUnicode, bSablier:=True) Then Me.TxtCheminDocument.Text = Me.oVBTxtFnd.m_sCheminFichierTxtDirect Application.DoEvents() AjouterDocument() 'CmdAjouterDocument_Click(New Object, New EventArgs) End If Else Dim bMemChapitrage As Boolean = Me.oVBTxtFnd.m_bIndexerChapitre Dim bMemUnicode As Boolean = Me.oVBTxtFnd.m_bOptionTexteUnicode Dim bMemAccents As Boolean = Me.oVBTxtFnd.IndexerAccents ' 24/05/2019 Voir s'il y a des info. sur l'unicode ' (car on ne la sauve pas encore dans l'index) Me.oVBTxtFnd.LireListeDocumentsIndexesIni() If Me.oVBTxtFnd.bLireIndex() Then ' Si l'index contenait du unicode, alors passer en unicode Dim bUnicode As Boolean = Me.oVBTxtFnd.m_bOptionTexteUnicode Dim bAccents As Boolean = Me.oVBTxtFnd.IndexerAccents Dim bChapitrage As Boolean = Me.oVBTxtFnd.m_bIndexerChapitre If bUnicode <> bMemUnicode Then Me.chkUnicode.Checked = bUnicode Me.m_bSauverOption_bTexteUnicode = False ' Ne pas sauver l'option alors End If If bAccents <> bMemAccents Then Me.chkAccents.Checked = bAccents Me.m_bSauverOption_bIndexerAccents = False ' Ne pas sauver l'option alors End If If bChapitrage <> bMemChapitrage Then Me.chkChapitrage.Checked = bChapitrage Me.m_bSauverOption_bIndexerChapitrage = False ' Ne pas sauver l'option alors End If Me.oVBTxtFnd.ListerDocumentsIndexes(Me.TxtResultat, bListerPhrases:=False) Else ' Fichier document traité par défaut, pour l'exemple Dim sFiltreTxt$ = Me.oVBTxtFnd.m_sCheminDossierCourant & "\*.txt" Me.TxtCheminDocument.Text = sFiltreTxt Me.tcOnglets.SelectedIndex = iOngletIndexer '' Démo VBTF : voir si le fichier Proverbes.txt existe 'Dim sCheminDemo = Application.StartupPath & "\Proverbes.txt" 'If bFichierExiste(sCheminDemo) Then Me.TxtCheminDocument.Text = sCheminDemo End If End If VerifierOperationsPossibles() If Me.TxtMot.Enabled Then Me.TxtMot.Focus() ' Options passées en argument de la ligne de commande ' Cette fct ne marche pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArgLigneCmd$ = Microsoft.VisualBasic.Interaction.Command 'If bDebug Then Me.TxtMot.Text = sGm & "Le temps" & sGm 'If bDebug Then Me.TxtMot.Text = "temps" If bDebug AndAlso sArgLigneCmd.Length = 0 Then Me.tcOnglets.SelectedIndex = iOngletOutils 'Me.TxtCheminDocument.Text = Application.StartupPath & "\VBTextFinder.html" 'Me.TxtCheminDocument.Text = Application.StartupPath & "\Tmp\LisezMoi.htm" 'Me.TxtCheminDocument.Text = Application.StartupPath & "\Tmp\LisezMoi.txt" 'Me.TxtCheminDocument.Text = Application.StartupPath & "\Proverbes.txt" 'Me.TxtCheminDocument.Text = Application.StartupPath & "\Tmp\Test4.txt" End If End Sub #End Region #Region "Gestion des événements" Private Sub CmdChoisirFichierDoc_Click(eventSender As Object, _ eventArgs As EventArgs) Handles CmdChoisirFichierDoc.Click ' Gerer la boîte de dialogue pour choisir un fichier document Word à indexer Const sMsgFiltreDoc$ = _ "Document Texte (*.txt) : bloc-notes Windows|*.txt|" & _ "Document Word (*.doc)|*.doc|Document Html (*.htm ou *.html) : web|*.htm*|" & _ "Autre document (*.*)|*.*" Const sMsgTitreBoiteDlg$ = _ "Veuillez choisir un fichier texte ou un document convertible en .txt" Dim sInitDir$ = "", sFichier$ = "" ' Initialiser le chemin seulement la première fois Static bDejaInit As Boolean If Not bDejaInit Then bDejaInit = True sInitDir = Me.oVBTxtFnd.m_sCheminDossierCourant End If If bChoisirFichier(sFichier, sMsgFiltreDoc, "*.txt", sMsgTitreBoiteDlg, _ sInitDir, bMultiselect:=False) Then ' ToDo : traiter multisélect ' Convertir le fichier en .txt si son extension ' est celle d'un document convertible (.doc, .html ou .htm) 'Dim bVerifierUnicode As Boolean = My.Settings.bVerifierUnicode Dim bVerifierUnicode As Boolean = Me.chkUnicodeVerif.Checked ' 01/06/2019 If Me.oVBTxtFnd.bConvertirDocEnTxt(sFichier, bVerifierUnicode, _ Me.oVBTxtFnd.m_bAuMoinsUnTxtUnicode, Me.oVBTxtFnd.m_bAvertAuMoinsUnTxtUnicode, Me.oVBTxtFnd.m_bInfoAuMoinsUnTxtNonUnicode, bSablier:=True) Then _ Me.TxtCheminDocument.Text = sFichier Me.oVBTxtFnd.Sablier(bDesactiver:=True) End If VerifierOperationsPossibles(bVerifDocumentSeul:=True) End Sub Private Sub CmdAjouterDocument_Click(eventSender As Object, _ eventArgs As EventArgs) Handles CmdAjouterDocument.Click AjouterDocument() End Sub Private Sub CmdChercher_Click(eventSender As Object, eventArgs As EventArgs) _ Handles CmdChercher.Click Chercher() End Sub Private Sub CmdInterrompre_Click(eventSender As Object, _ eventArgs As EventArgs) Handles CmdInterrompre.Click Me.m_msgDelegue.m_bAnnuler = True Me.oVBTxtFnd.Interrompre() End Sub Private Sub TxtCheminDocument_TextChanged(eventSender As Object, _ eventArgs As EventArgs) Handles TxtCheminDocument.TextChanged VerifierActivationCmdIndexer() End Sub Private Sub TxtCheminDocument_DoubleClick(sender As Object, e As EventArgs) _ Handles TxtCheminDocument.DoubleClick BasculerFiltreIndexationFichiers() End Sub Private Sub LstTypeIndex_Click(sender As Object, e As EventArgs) _ Handles lstTypeIndex.Click AfficherDescriptionDocIndex() End Sub Private Sub LstTypeIndex_DoubleClick(eventSender As Object, _ eventArgs As EventArgs) Handles lstTypeIndex.DoubleClick CreerDocIndex() End Sub 'Private Sub LstTypeAffichResult_SelectedIndexChanged(eventSender As Object, _ ' eventArgs As EventArgs) Handles LstTypeAffichResult.SelectedIndexChanged ' ScrollParagPredef() 'End Sub Private Sub LstTypeAffichResult_Click(eventSender As Object, _ eventArgs As EventArgs) Handles LstTypeAffichResult.Click ScrollParagPredef() End Sub Private Sub vsbZoomParag_ValueChanged(sender As Object, e As EventArgs) _ Handles vsbZoomParag.ValueChanged ScrollParag() End Sub Private Sub TxtMot_TextChanged(eventSender As Object, _ eventArgs As EventArgs) Handles TxtMot.TextChanged VerifierOperationsPossibles() End Sub Private Sub TxtMot_KeyDown(eventSender As Object, _ eventArgs As Windows.Forms.KeyEventArgs) Handles TxtMot.KeyDown Dim iTouche% = eventArgs.KeyCode 'Dim Shift% = eventArgs.KeyData \ &H10000 AfficherMotsCompatEnCoursDeFrappe(iTouche) End Sub Private Sub TxtResultat_MouseUp(eventSender As Object, _ eventArgs As EventArgs) Handles TxtResultat.MouseUp ' Si on relache la souris, alors noter le curseur Me.oVBTxtFnd.NoterPositionCurseur(Me.TxtResultat, Me.chkAfficherInfoResultat.Checked, _ Me.chkAfficherNumParag.Checked, Me.chkAfficherNumPhrase.Checked) End Sub 'Private Sub TxtResultat_Leave(sender As Object, e As EventArgs) _ ' Handles TxtResultat.LostFocus ' If m_bQuitter Then Exit Sub ' Debug.WriteLine(Now & " : Memo pos. curseur") ' Me.oVBTxtFnd.NoterPositionCurseur(Me.TxtResultat, Me.chkInfoParag.Checked) 'End Sub Private Sub TxtResultat_DoubleClick(eventSender As Object, _ eventArgs As EventArgs) Handles TxtResultat.DoubleClick HyperTexte() End Sub Private Sub chkAfficherInfoResultat_Click(sender As Object, e As EventArgs) _ Handles chkAfficherInfoResultat.Click Chercher() End Sub Private Sub chkAfficherInfoDoc_Click(sender As Object, e As EventArgs) _ Handles chkAfficherInfoDoc.Click Chercher() End Sub Private Sub chkAfficherNumParag_Click(sender As Object, e As EventArgs) _ Handles chkAfficherNumParag.Click Chercher() End Sub Private Sub chkAfficherNumPhrase_Click(sender As Object, e As EventArgs) _ Handles chkAfficherNumPhrase.Click Chercher() End Sub Private Sub chkNumerotationGlobale_Click(sender As Object, e As EventArgs) _ Handles chkNumerotationGlobale.Click Chercher() End Sub Private Sub chkAfficherNumOccur_Click(sender As Object, e As EventArgs) _ Handles chkAfficherNumOccur.Click Chercher() End Sub Private Sub chkAfficherTiret_Click(sender As Object, e As EventArgs) _ Handles chkAfficherTiret.Click Chercher() End Sub Private Sub chkMotsDico_Click(sender As Object, e As EventArgs) _ Handles chkMotsDico.Click VerifierDico() End Sub Private Sub lbCodesLangues_Click(sender As Object, e As EventArgs) _ Handles lbCodesLangues.Click Me.tbCodeLangue.Text = Me.lbCodesLangues.SelectedItem.ToString Me.oVBTxtFnd.ReinitDico() ' 03/05/2014 Penser à recharger le dico si on change de langue End Sub 'Private Sub frmVBTextFinder_DoubleClick(sender As Object, _ ' e As EventArgs) Handles MyBase.DoubleClick ' ListerDocumentsIndexes() 'End Sub Private Sub cmdListeDoc_Click(sender As Object, e As EventArgs) _ Handles cmdListeDoc.Click ListerDocumentsIndexes() End Sub Private Sub cmdListeDocHtml_Click(sender As Object, e As EventArgs) _ Handles cmdListeDocHtml.Click ListerDocumentsIndexes(bHtml:=True) AfficherHtml(bVerifierIdem:=False) End Sub Private Sub tcOnglets_SelectedIndexChanged(sender As Object, e As EventArgs) _ Handles tcOnglets.SelectedIndexChanged AfficherHtml() End Sub Private Sub wbResultat_DocumentCompleted(sender As Object, _ e As Windows.Forms.WebBrowserDocumentCompletedEventArgs) _ Handles wbResultat.DocumentCompleted ' Conserver le fichier, car on pourra l'afficher dans le navigateur externe 'If bDebug Then Exit Sub 'If Not bFichierExiste(sCheminHtmlTmp) Then Exit Sub 'bSupprimerFichier(sCheminHtmlTmp) End Sub Private Sub cmdNavigExterne_Click(sender As Object, e As EventArgs) _ Handles cmdNavigExterne.Click If IsNothing(oVBTxtFnd.m_sbResultatHtml) Then Exit Sub If Not bFichierExiste(sCheminHtmlTmp) Then Exit Sub OuvrirAppliAssociee(sCheminHtmlTmp) End Sub Private Sub cmdExporterTxt_Click(sender As Object, e As EventArgs) _ Handles cmdExporterTxt.Click If IsNothing(oVBTxtFnd.m_sbResultatTxt) Then Exit Sub Dim iEncodage% = iCodePageWindowsLatin1252 If oVBTxtFnd.m_bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 If Not bEcrireFichier(sCheminTxtTmp, oVBTxtFnd.m_sbResultatTxt, _ iEncodage:=iEncodage) Then Exit Sub OuvrirAppliAssociee(sCheminTxtTmp) 'bSupprimerFichier(sCheminTxtTmp) End Sub #End Region #Region "Indexation" Private Sub BasculerFiltreIndexationFichiers() Static sMemChemin$ Dim sFiltreTxt$ = Me.oVBTxtFnd.m_sCheminDossierCourant & "\*.txt" Dim sFiltreDoc$ = Me.oVBTxtFnd.m_sCheminDossierCourant & "\*.doc" Dim sFiltreHtm$ = Me.oVBTxtFnd.m_sCheminDossierCourant & "\*.htm?" If Me.TxtCheminDocument.Text <> sFiltreTxt And _ Me.TxtCheminDocument.Text <> sFiltreDoc And _ Me.TxtCheminDocument.Text <> sFiltreHtm Then sMemChemin = Me.TxtCheminDocument.Text End If If Me.TxtCheminDocument.Text = sFiltreTxt Then Me.TxtCheminDocument.Text = sFiltreDoc ElseIf Me.TxtCheminDocument.Text = sFiltreDoc Then Me.TxtCheminDocument.Text = sFiltreHtm ElseIf Me.TxtCheminDocument.Text = sFiltreHtm Then If sMemChemin <> "" Then Me.TxtCheminDocument.Text = sMemChemin Else Me.TxtCheminDocument.Text = sFiltreTxt End If Else Me.TxtCheminDocument.Text = sFiltreTxt End If VerifierActivationCmdIndexer() End Sub Private Sub AjouterDocument() ' Indexer un nouveau document ' Interdire la ré-entrance dans cette fonction Me.CmdAjouterDocument.Enabled = False ' Autoriser l'interruption de l'indexation Me.CmdInterrompre.Enabled = True Me.CmdChercher.Enabled = False Me.oVBTxtFnd.m_bIndexerChapitre = Me.chkChapitrage.Checked 'Me.oVBTxtFnd.m_sChapitrage = Me.tbChapitrage.Text 'Dim bVerifierUnicode As Boolean = My.Settings.bVerifierUnicode Dim bVerifierUnicode As Boolean = Me.chkUnicodeVerif.Checked ' 01/06/2019 If Me.oVBTxtFnd.bIndexerDocuments(Me.TxtCheminDocument.Text, bVerifierUnicode) Then ' 28/08/2009 Onglet résultat de l'indexation : onglet n°1 Me.tcOnglets.SelectedIndex = iOngletRechercher Me.TxtMot.Focus() End If Me.CmdInterrompre.Enabled = False Me.oVBTxtFnd.ListerDocumentsIndexes(Me.TxtResultat) VerifierOperationsPossibles() End Sub #End Region #Region "Traitements" Private Sub AfficherMotsCompatEnCoursDeFrappe(iTouche%) ' Traiter la touche Entrée sur la zone de saisie n°1 If iTouche <> Windows.Forms.Keys.Return Then Exit Sub Me.CmdInterrompre.Enabled = True Me.CmdInterrompre.Focus() Chercher() Me.TxtMot.Focus() End Sub Private Sub Chercher() ' Chercher les occurrences d'un mot ' 01/05/2010 Inutile de proposer d'interrompre, car il n'y a qu'une seule ligne ' de code qui prend du temps : CtrlResultat.Text = sbResultat.ToString ' et on ne peut l'annuler (pas de AppendText possible ?) ' Oui mais alors faire une fct ActivationCmd(bDésactiver) et un booleen ' car on utilise Me.CmdInterrompre.Enabled pour savoir ' On pourra cependant annuler le ctrl web Me.CmdInterrompre.Enabled = True Me.CmdChercher.Enabled = False ' Eviter la ré-entrance dans la fonction Me.oVBTxtFnd.InitNouvelleRecherche() ' Effacer mémo. curseur : nouv. recherche ChercherDirect() Me.CmdInterrompre.Enabled = False Me.CmdChercher.Enabled = True End Sub Private Sub ChercherDirect() ' Faire une recherche, ou refaire une recherche avec un affichage différent Dim sExpression$ = Me.TxtMot.Text Dim bMotExiste As Boolean = False Dim oMot As clsMot = Nothing bMotExiste = Me.oVBTxtFnd.bMotExiste(sExpression, oMot) Dim bGuillemet As Boolean = False Dim sSepGm$ = Chr(iCodeASCIIGuillemet) If sExpression.IndexOf(sSepGm) > -1 Then bGuillemet = True Dim bEspace As Boolean = (sExpression.IndexOf(" ") > 1) If Not bGuillemet And Not bMotExiste And Not bEspace Then Exit Sub Dim bHtml As Boolean = False If Me.tcOnglets.SelectedIndex = iOngletWeb Then bHtml = True Me.oVBTxtFnd.m_bOccurrencesEnGras = Me.chkHtmlGras.Checked Me.oVBTxtFnd.m_bOccurrencesEnCouleurs = Me.chkHtmlCouleurs.Checked Me.oVBTxtFnd.m_sCouleursHtml = Me.tbCouleursHtml.Text Me.oVBTxtFnd.m_bNumerotationGlobale = Me.chkNumerotationGlobale.Checked If bGuillemet Or bEspace Then Me.oVBTxtFnd.ChercherOccurrencesMots( _ Me.TxtMot, Me.TxtResultat, Me.vsbZoomParag.Value, _ Me.chkAfficherInfoResultat.Checked, Me.chkAfficherInfoDoc.Checked, _ Me.chkAfficherNumParag.Checked, Me.chkAfficherNumPhrase.Checked, _ Me.chkAfficherNumOccur.Checked, Me.chkAfficherTiret.Checked, bHtml) Else Me.oVBTxtFnd.ChercherOccurrencesMot( _ Me.TxtMot, Me.TxtResultat, Me.vsbZoomParag.Value, _ Me.chkAfficherInfoResultat.Checked, Me.chkAfficherInfoDoc.Checked, _ Me.chkAfficherNumParag.Checked, Me.chkAfficherNumPhrase.Checked, _ Me.chkAfficherNumOccur.Checked, Me.chkAfficherTiret.Checked, bHtml) End If End Sub Private Sub HyperTexte() ' Quitter si une opération est en cours If Me.CmdInterrompre.Enabled Then Exit Sub Dim sMotSelFin$ = "" If Me.oVBTxtFnd.bHyperTexte((Me.TxtResultat.SelectedText), sMotSelFin) Then Me.TxtMot.Text = sMotSelFin Chercher() End If End Sub Private Sub AfficherHtml(Optional bVerifierIdem As Boolean = True) If Me.tcOnglets.SelectedIndex <> iOngletWeb Then Exit Sub Static iMemNbParag% = -2 Static bMemAfficherInfoResultat, bMemAfficherNumOccur As Boolean Static bMemAfficherInfoDoc, bMemNumerotationGlobale As Boolean Static bMemAfficherNumParag, bMemAfficherNumPhrase As Boolean Static bMemAfficherTiret As Boolean Static sMemExpressions$ = "" Static bMemHtmlGras, bMemHtmlCouleur As Boolean Static sMemCouleursHtml$ = "" Static bMemChapitre As Boolean Static iMemNbDoc% = 0 Static bMemListeDoc As Boolean If Not bVerifierIdem Then GoTo Suite ' Si l'affichage a changé alors refaire le html complètement If bMemAfficherInfoResultat <> chkAfficherInfoResultat.Checked OrElse _ bMemAfficherInfoDoc <> chkAfficherInfoDoc.Checked OrElse _ bMemNumerotationGlobale <> chkNumerotationGlobale.Checked OrElse _ bMemAfficherNumParag <> chkAfficherNumParag.Checked OrElse _ bMemAfficherNumPhrase <> chkAfficherNumPhrase.Checked OrElse _ bMemAfficherNumOccur <> chkAfficherNumOccur.Checked OrElse _ bMemAfficherTiret <> chkAfficherTiret.Checked OrElse _ iMemNbParag <> vsbZoomParag.Value OrElse _ sMemExpressions <> TxtMot.Text OrElse _ bMemHtmlGras <> chkHtmlGras.Checked OrElse _ bMemHtmlCouleur <> chkHtmlCouleurs.Checked OrElse _ sMemCouleursHtml <> tbCouleursHtml.Text OrElse _ bMemChapitre <> chkAfficherChapitreIndex.Checked OrElse _ iMemNbDoc <> oVBTxtFnd.iNbDocumentsIndexes OrElse _ bMemListeDoc <> (Not bVerifierIdem) Then Chercher() 'If IsNothing(oVBTxtFnd.m_sbResultatHtml) Then Exit Sub Else 'If Not IsNothing(oVBTxtFnd.m_sbResultatHtml) Then ' ' Déjà affiché correctement ' Exit Sub 'End If Exit Sub End If bMemAfficherInfoResultat = chkAfficherInfoResultat.Checked bMemAfficherInfoDoc = chkAfficherInfoDoc.Checked bMemNumerotationGlobale = chkNumerotationGlobale.Checked bMemAfficherNumParag = chkAfficherNumParag.Checked bMemAfficherNumPhrase = chkAfficherNumPhrase.Checked bMemAfficherNumOccur = chkAfficherNumOccur.Checked bMemAfficherTiret = chkAfficherTiret.Checked sMemExpressions = TxtMot.Text iMemNbParag = vsbZoomParag.Value bMemHtmlGras = chkHtmlGras.Checked bMemHtmlCouleur = chkHtmlCouleurs.Checked sMemCouleursHtml = tbCouleursHtml.Text bMemChapitre = chkAfficherChapitreIndex.Checked iMemNbDoc = oVBTxtFnd.iNbDocumentsIndexes Suite: ' Si on ne vérifie pas, c'est pour afficher la liste des docs bMemListeDoc = Not bVerifierIdem Me.wbResultat.Focus() ' Recevoir les raccourcis clavier Me.wbResultat.Navigate("") If IsNothing(oVBTxtFnd.m_sbResultatHtml) Then Exit Sub 'Dim iEncodage% = iCodePageWindowsLatin1252 'If oVBTxtFnd.m_bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 ' 26/10/2019 Tous les documents html doivent être en UTF8 (ça doit être l'encodage html par défaut) If Not bEcrireFichier(sCheminHtmlTmp, oVBTxtFnd.m_sbResultatHtml, bEncodageUTF8:=True) Then Exit Sub ' Si le texte est trop long, éviter le menu Copié/Collé : très très long ! ' alors que navigateur externe : ok ' On laisse le ctrl-C mais attention avec ctrl-A ctrl-C : très très long ! If oVBTxtFnd.m_sbResultatHtml.Length > iMaxLongChaine0 Then Me.wbResultat.IsWebBrowserContextMenuEnabled = False Else Me.wbResultat.IsWebBrowserContextMenuEnabled = True End If Me.wbResultat.Navigate(New System.Uri(sCheminHtmlTmp)) End Sub #End Region #Region "Divers" Private Sub ScrollParagPredef() 'Debug.WriteLine(Now & " : ScrollParagPredef") ' Gerer le type d'affichage des résultats (phrase ou paragraphe) ' Verifier si sélectionné, pas seulement si text = x 'Me.bClickParag = True If Me.LstTypeAffichResult.SelectedIndices.Contains(4) Then ' +-3 § Me.vsbZoomParag.Value = 3 ElseIf Me.LstTypeAffichResult.SelectedIndices.Contains(3) Then ' +-2 § Me.vsbZoomParag.Value = 2 ElseIf Me.LstTypeAffichResult.SelectedIndices.Contains(2) Then ' +-1 § Me.vsbZoomParag.Value = 1 ElseIf Me.LstTypeAffichResult.SelectedIndices.Contains(1) Then ' § du mot trouvé Me.vsbZoomParag.Value = 0 ElseIf Me.LstTypeAffichResult.SelectedIndices.Contains(0) Then ' Phrase du mot trouvé Me.vsbZoomParag.Value = -1 Else ' § > +-3 End If 'Me.bClickParag = False End Sub Private Sub ScrollParag() ' Gerer le type d'affichage des résultats (phrase ou paragraphe) 'Dim bNoterPosCurseur As Boolean = True If Me.vsbZoomParag.Value = 3 Then ' +-3 § Me.LstTypeAffichResult.Text = clsVBTextFinder.sAfficherParagPM3 ElseIf Me.vsbZoomParag.Value = 2 Then ' +-2 § Me.LstTypeAffichResult.Text = clsVBTextFinder.sAfficherParagPM2 ElseIf Me.vsbZoomParag.Value = 1 Then ' +-1 § Me.LstTypeAffichResult.Text = clsVBTextFinder.sAfficherParagPM1 ElseIf Me.vsbZoomParag.Value = 0 Then ' § du mot trouvé Me.LstTypeAffichResult.Text = clsVBTextFinder.sAfficherParag ElseIf Me.vsbZoomParag.Value = -1 Then ' Phrase du mot trouvé Me.LstTypeAffichResult.Text = clsVBTextFinder.sAfficherPhrase 'bNoterPosCurseur = False Else Dim i% For i = 0 To Me.LstTypeAffichResult.Items.Count - 1 Me.LstTypeAffichResult.SetSelected(i, False) Next End If If Not m_bInit Then Exit Sub If Not Me.CmdChercher.Enabled Then GoTo Fin ChercherDirect() Exit Sub Fin: Me.LblAvancement.Text = "Nombre de paragraphes affichés autour du mot : " & _ Me.vsbZoomParag.Value End Sub Private Sub VerifierOperationsPossibles( _ Optional bVerifDocumentSeul As Boolean = False) ' Vérifier les opérations possibles selon l'état de l'interface ' Si une indexation est en cours, ne pas réactiver les boutons de commande If Me.CmdInterrompre.Enabled Then Exit Sub Dim sMsgMot$ = "", sMsg$ = "", sMsgDoc$ = "" If Me.oVBTxtFnd.iNbDocumentsIndexes > 0 Then Me.TxtMot.Enabled = True Else sMsgMot = "Aucun document n'est indexé" End If ' 10/10/2009 Nouvelle méthode de recherche : parcourir les phrases ' toujours laisser la possibilité de chercher une expression Me.CmdChercher.Enabled = True ' Activer le bouton Chercher si le mot existe 'Me.CmdChercher.Enabled = False Dim oMot As clsMot = Nothing If Not Me.oVBTxtFnd.bMotExiste(Me.TxtMot.Text, oMot) Then If Me.TxtMot.Text <> "" Then sMsgMot = "Mot non trouvé : " & Me.TxtMot.Text Else sMsgMot = "Mot trouvé : " & Me.TxtMot.Text & _ " (" & oMot.iNbOccurrences & " occurrences)" Me.CmdChercher.Enabled = True End If ' Vérifier si le fichier document existe Me.CmdAjouterDocument.Enabled = False If Not bFichierExisteFiltre2(Me.TxtCheminDocument.Text) Then If Me.TxtCheminDocument.Text <> "" Then _ sMsgDoc = "Fichier inexistant : " & Me.TxtCheminDocument.Text GoTo Fin End If ' Activer le bouton Ajouter (un document à indexer) Me.CmdAjouterDocument.Enabled = True Fin: sMsg = sMsgMot If sMsgDoc <> "" Then sMsg = sMsgDoc If bVerifDocumentSeul Then sMsg = sMsgDoc If sMsg <> "" Or Not bVerifDocumentSeul Then Me.LblAvancement.Text = sMsg End Sub Private Sub VerifierActivationCmdIndexer() ' Vérifier si le bouton Indexer peut être activé ' Si une indexation est en cours, ne pas réactiver les boutons de commande If Me.CmdInterrompre.Enabled Then Exit Sub Dim sMsg$ = "" ' Vérifier si le fichier document existe Me.CmdAjouterDocument.Enabled = False If Not bFichierExisteFiltre2(Me.TxtCheminDocument.Text) Then If Me.TxtCheminDocument.Text <> "" Then _ sMsg = "Fichier inexistant : " & Me.TxtCheminDocument.Text GoTo Fin End If ' Activer le bouton Ajouter (un document à indexer) Me.CmdAjouterDocument.Enabled = True Fin: Me.LblAvancement.Text = sMsg End Sub Private Sub ListerDocumentsIndexes(Optional bHtml As Boolean = False) Me.oVBTxtFnd.LireListeDocumentsIndexesIni() Me.oVBTxtFnd.ListerDocumentsIndexes(Me.TxtResultat, _ bListerPhrases:=Not bHtml, bHtml:=bHtml) If Not bHtml Then Me.oVBTxtFnd.AfficherFichierIni() End Sub Private Sub CreerDocIndex() If Me.oVBTxtFnd.iNbDocumentsIndexes = 0 Then Me.LblAvancement.Text = "Aucun document indexé" Exit Sub End If ' Quitter si une opération est en cours If Me.CmdInterrompre.Enabled Then Exit Sub Dim sCheminDico0 = "" If Not Me.chkMotsDico.Checked AndAlso Not bChercherDico(sCheminDico0) Then MsgBox("Le dictionnaire est introuvable :" & vbLf & _ sCheminDico0, MsgBoxStyle.Exclamation) Exit Sub End If Dim iNbMotsCles% = 0 Integer.TryParse(Me.mtbNbMotsCles.Text, iNbMotsCles) If iNbMotsCles = 0 Then iNbMotsCles = iMaxMotsClesDef Me.oVBTxtFnd.m_bAfficherChapitreIndex = Me.chkAfficherChapitreIndex.Checked Me.CmdInterrompre.Enabled = True Me.oVBTxtFnd.CreerDocIndex(Me.lstTypeIndex.Text, _ Me.chkMotsDico.Checked, Me.chkMotsCourants.Checked, _ sCheminDico0, Me.tbCodeLangue.Text, _ Me.chkListeMots.Checked, iNbMotsCles, Me.chkNumeriques.Checked, _ Me.tbCodesLangues.Text) Me.CmdInterrompre.Enabled = False End Sub Private Sub cmdGlossaire_Click(sender As Object, e As EventArgs) Handles cmdGlossaire.Click If Me.TxtCheminDocument.Text.Length = 0 Then ' 05/05/2018 MsgBox("Le nom du fichier à analyser n'est pas précisé !", MsgBoxStyle.Exclamation) Me.tcOnglets.SelectedIndex = iOngletIndexer Exit Sub End If If Not bFichierExiste(Me.TxtCheminDocument.Text, bPrompt:=True) Then Exit Sub Me.m_msgDelegue.m_bAnnuler = False Me.CmdInterrompre.Enabled = True Me.cmdGlossaire.Enabled = False Me.tcOnglets.Enabled = False Dim bTriFreq As Boolean = False If Me.lstTypeIndex.Text = clsVBTextFinder.sIndexFreq Then bTriFreq = True bCreerGlossaire(Me.TxtCheminDocument.Text, Me.lbCodesLangues.Text, m_msgDelegue, _ bTriFreq, bVoirGlossaireCourant:=False) Me.m_msgDelegue.m_bAnnuler = False Me.CmdInterrompre.Enabled = False Me.tcOnglets.Enabled = True Me.cmdGlossaire.Enabled = True End Sub Private Sub AfficherDescriptionDocIndex() Select Case Me.lstTypeIndex.Text Case clsVBTextFinder.sIndexAlpha : Me.LblAvancement.Text = _ "Double-clic pour créer le document index par ordre alphabétique" Case clsVBTextFinder.sIndexFreq : Me.LblAvancement.Text = _ "Double-clic pour créer le document index par ordre fréquentiel" Case clsVBTextFinder.sIndexMotsCles : Me.LblAvancement.Text = _ "Double-clic pour extraire les mots clés" Case clsVBTextFinder.sIndexCitations : Me.LblAvancement.Text = _ "Double-clic pour extraire la liste des citations" Case clsVBTextFinder.sIndexSimple : Me.LblAvancement.Text = _ "Double-clic pour extraire la simple liste des mots indexés (avec le suffixe du code langue sélectionné)" Case clsVBTextFinder.sIndexSimpleComparer : Me.LblAvancement.Text = _ "Double-clic pour faire l'intersection des index simples dans les codes langues disponibles" Case clsVBTextFinder.sIndexTout : Me.LblAvancement.Text = _ "Double-clic pour exporter toutes les phrases indexées" Case clsVBTextFinder.sIndexNGrammes : Me.LblAvancement.Text = _ "Double-clic pour exporter les N-Grammes les plus fréquents du dictionnaire de mot" Case clsVBTextFinder.sIndexEspacesInsecables : Me.LblAvancement.Text = _ "Double-clic pour exporter tous les espaces insécables" Case clsVBTextFinder.sIndexEspacesInsecablesAVerifier : Me.LblAvancement.Text = _ "Double-clic pour exporter les espaces insécables à vérifier" Case clsVBTextFinder.sIndexMajuscules : Me.LblAvancement.Text = _ "Double-clic pour exporter les majuscules intempestives" Case clsVBTextFinder.sIndexAccents : Me.LblAvancement.Text = _ "Double-clic pour analyser les accents manquants (sur les majuscules notamment)" End Select End Sub Private Sub VerifierDico() If Me.chkMotsDico.Checked Then Exit Sub Dim sCheminDico0$ = "" If bChercherDico(sCheminDico0) Then Exit Sub Me.chkMotsDico.Checked = True ' Rétablir 'Me.chkMotsDico.Checked = False Dim sUrl$ = "" Select Case Me.tbCodeLangue.Text Case sCodeLangueFr : sUrl = sURLDicoFr Case sCodeLangueEn : sUrl = sURLDicoEn Case sCodeLangueUk : sUrl = sURLDicoUk Case sCodeLangueUS : sUrl = sURLDicoUs Case Else : sUrl = "" End Select If sUrl.Length = 0 Then MsgBox( _ "Le dictionnaire est introuvable :" & vbLf & _ sCheminDico0, MsgBoxStyle.Exclamation) Exit Sub End If If MsgBoxResult.Cancel = MsgBox( _ "Le dictionnaire est introuvable :" & vbLf & _ sCheminDico0 & vbLf & _ "Cliquez sur OK pour le télécharger :" & vbLf & sUrl, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sUrl, bVerifierFichier:=False) End Sub Private Function bChercherDico(ByRef sCheminDicoFinal$) As Boolean ' 05/05/2018 Dictionnaire _Fr pour le français aussi Dim sCheminDico0 = Application.StartupPath & sCheminDico & "_" & _ Me.tbCodeLangue.Text & sExtTxt sCheminDicoFinal = sCheminDico0 Dim bExiste0 = bFichierExiste(sCheminDico0) Return bExiste0 'If Me.tbCodeLangue.Text <> sCodeLangueFr Then ' If Not bFichierExiste(sCheminDico0) Then Return False 'Else ' ' Si Fr alors vérifier aussi le fichier de la version précédante ' Dim sCheminDico1 = Application.StartupPath & sCheminDicoV1Fr ' Dim bExiste1 = bFichierExiste(sCheminDico1) ' If Not bExiste0 And Not bExiste1 Then Return False ' If Not bExiste0 And bExiste1 Then sCheminDico0 = sCheminDico1 'End If 'sCheminDicoFinal = sCheminDico0 'Return True End Function Private Sub AfficherMessage(sMsg$) Me.LblAvancement.Text = sMsg ' Laisser du temps pour le traitement des messages : affichage du message et ' traitement du clic éventuel sur le bouton Interrompre Application.DoEvents() End Sub Private Sub AfficherMsgDelegue(sender As Object, _ e As clsMsgEventArgs) Handles m_msgDelegue.EvAfficherMessage Me.AfficherMessage(e.sMessage) End Sub Private Sub AfficherMsgDelegue(sender As Object, _ e As clsSablierEventArgs) Handles m_msgDelegue.EvSablier Sablier(e.bDesactiver) 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 ' Curseur de l'application : il est réinitialisé à chaque Application.DoEvents ' ou bien lorsque l'application ne fait rien ' du coup, il faut insister grave pour conserver le contrôle du curseur tout en ' voulant afficher des messages de progression et vérifier les interruptions... Dim ctrl As Control For Each ctrl In Me.Controls ctrl.Cursor = Me.Cursor ' Curseur de chaque contrôle de la feuille Next ctrl Cursor.Current = Me.Cursor End Sub #End Region #Region "Gestion des menus contextuels" Private Sub VerifierMenuCtx() Dim sCleDescriptionCmd$ = sMenuCtx_TypeFichierIdx & "\shell\" & _ sMenuCtx_CleCmdIndexOuvrir If bCleRegistreCRExiste(sCleDescriptionCmd) Then Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True ' Si la clé existe pour .doc, voir s'il faut enlever aussi celle pour tous les fichiers (*.*) Dim sCleDescriptionCmdTous$ = sMenuCtx_TypeFichierTous & "\shell\" & _ sMenuCtx_CleCmdIndexer Me.chkTous.Checked = bCleRegistreCRExiste(sCleDescriptionCmdTous) Me.chkTous.Enabled = False ' Interdire de décocher Else Me.cmdAjouterMenuCtx.Enabled = True Me.cmdEnleverMenuCtx.Enabled = False Me.chkTous.Enabled = True ' Autoriser à cocher 'Me.chkTous.Checked = True ' Coché par défaut End If End Sub Private Sub cmdAjouterMenuCtx_Click(sender As Object, _ e As EventArgs) Handles cmdAjouterMenuCtx.Click AjouterMenuCtx() VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(sender As Object, _ e As EventArgs) Handles cmdEnleverMenuCtx.Click EnleverMenuCtx() VerifierMenuCtx() End Sub Private Sub AjouterMenuCtx() If MsgBoxResult.Cancel = MsgBox("Ajouter les menus contextuels ?", _ MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub AjouterMenuCtxIndexer(sMenuCtx_TypeFichierTxt) AjouterMenuCtxIndexer(sMenuCtx_TypeFichierDoc) If Me.chkTous.Checked Then AjouterMenuCtxIndexer(sMenuCtx_TypeFichierTous) AjouterMenuCtxIndexer(sMenuCtx_TypeDossier) Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sChemin$ = """%1""" ' Ajouter un pointeur HKCR\.idx vers HKCR\VBTextFinder bAjouterTypeFichier(sMenuCtx_ExtFichierIdx, sMenuCtx_TypeFichierIdx, _ sMenuCtx_ExtFichierIdxDescription) ' Menu contextuel pour ouvrir un index .idx bAjouterMenuContextuel(sMenuCtx_TypeFichierIdx, sMenuCtx_CleCmdIndexOuvrir, _ bPrompt, , sMenuCtx_CleCmdIndexOuvrirDescription, sCheminExe, sChemin, _ sMenuCtx_TypeFichierIdxDescription) End Sub Private Sub EnleverMenuCtx() If MsgBoxResult.Cancel = MsgBox("Enlever les menus contextuels ?", _ MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub ' Supprimer seulement les clés ajoutées pour chacun des types de fichier EnleverMenuCtxIndexer(sMenuCtx_TypeFichierTxt) EnleverMenuCtxIndexer(sMenuCtx_TypeFichierDoc) If Me.chkTous.Checked Then EnleverMenuCtxIndexer(sMenuCtx_TypeFichierTous) EnleverMenuCtxIndexer(sMenuCtx_TypeDossier) ' bEnleverTypeFichier : enlever toute l'arbo HKCR\VBTextFinder bAjouterMenuContextuel(sMenuCtx_TypeFichierIdx, sMenuCtx_CleCmdIndexOuvrir, _ bEnlever:=True, bPrompt:=False, bEnleverTypeFichier:=True) ' Puis enlever le pointeur HKCR\.idx vers HKCR\VBTextFinder bAjouterTypeFichier(sMenuCtx_ExtFichierIdx, sMenuCtx_TypeFichierIdx, _ bEnlever:=True) End Sub Private Sub AjouterMenuCtxIndexer(sMenuCtx_TypeFichier$) Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sChemin$ = """%1""" bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdIndexer, _ bPrompt, , sMenuCtx_CleCmdIndexerDescription, sCheminExe, sChemin) End Sub Private Sub EnleverMenuCtxIndexer(sMenuCtx_TypeFichier$) bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdIndexer, _ bEnlever:=True, bPrompt:=False) End Sub #End Region End Class clsVBTxtFnd.vb ' Fichier clsVBTxtFnd.vb ' ---------------------- Imports System.Text ' Pour StringBuilder Imports System.Text.Encoding ' Pour GetEncoding Imports System.Collections.Specialized.CollectionsUtil ' Pour CreateCaseInsensitiveHashtable Friend Class clsVBTextFinder ' Classe principale du moteur de recherche VBTextFinder #Region "Interface publique" Public Delegate Sub GestEvAfficherMessage(sender As Object, _ e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage Public m_sCheminDossierCourant$ ' Types d'index Public Const sIndexAlpha$ = "Alphabétique" Public Const sIndexFreq$ = "Fréquentiel" Public Const sIndexMotsCles$ = "Mots clés" Public Const sIndexCitations$ = "Citations" Public Const sIndexSimple$ = "Simple" Public Const sIndexSimpleComparer$ = "Simple : comparer" Public Const sIndexTout$ = "Tout" Public Const sIndexEspacesInsecables$ = "Espaces insécables" Public Const sIndexEspacesInsecablesAVerifier$ = "Esp. inséc. à vérif." Public Const sIndexMajuscules$ = "Majuscules" Public Const sIndexAccents$ = "Accents manquants" ' 06/06/2019 ' Analyse de la fréquence de successions des lettres dans les mots : Projet en cours Public Const sIndexNGrammes$ = "N-Grammes" Public Const sPrefixeIndex$ = "Index" ' Ne pas indexer tout fichier commençant par Index Public Const sPrefixeIndexSimple$ = "IndexSimple" Public Const sPrefixeIndexCitations$ = "IndexCitations" Public Const sPrefixeEspacesInsecables$ = "EspacesInsecables" Public Const sPrefixeMajuscules$ = "Majuscules" ' Types d'affichage des résultats de recherche Public Const sAfficherPhrase$ = "Phrase" Public Const sAfficherParag$ = "Paragraphe" Public Const sAfficherParagPM1$ = "Paragraphe +-1" Public Const sAfficherParagPM2$ = "Paragraphe +-2" Public Const sAfficherParagPM3$ = "Paragraphe +-3" ' Indexation directe d'un fichier texte passé ' en argument de la ligne de commande Public m_bModeDirect As Boolean = False Public m_sCheminFichierTxtDirect$ = "" Public iNbPhrasesG% ' (= m_colPhrases.Count) Public iNbMotsG% ' Nombre de mots indexés en tout Public iNbParagG% ' Nombre de paragraphes indexés en tout (sans les lignes vides) Public m_sbResultatHtml As StringBuilder Public m_sbResultatTxt As StringBuilder ' sMotsCourants ne contient pas les accents : ' les mots clés ne fonctionneront plus si on indexe les accents Private m_bIndexerAccents As Boolean = False Private m_styleCompare% = StringComparison.InvariantCultureIgnoreCase Private m_styleCompare2 As System.StringComparison = StringComparison.InvariantCultureIgnoreCase Public Property IndexerAccents As Boolean Get Return m_bIndexerAccents End Get Set(value As Boolean) 'Dim bAccent = m_bIndexerAccents m_bIndexerAccents = value ' Non, en fait cela n'a pas d'impact sur l'indexation, ' car on n'enlève les accents par le code, pas par une option de comparaison : ' (à faire seulement si on veut distinguer la casse, pas les accents) 'If m_bIndexerAccents Then ' m_styleCompare = StringComparison.InvariantCulture ' m_styleCompare2 = StringComparison.InvariantCulture 'Else ' m_styleCompare = StringComparison.InvariantCultureIgnoreCase ' m_styleCompare2 = StringComparison.InvariantCultureIgnoreCase 'End If 'If bAccent <> m_bIndexerAccents Then ' m_htMots = New Hashtable(m_styleCompare) 'End If End Set End Property ' Hashtable des mots indexés avec pour clé : sMot sans accent (par défaut) ' Si on indexe les accents (bIndexerAccents = True) ' le constructeur par défaut de Hastable ne fonctionne pas avec ' des mots tels que "Drôle" (et InvariantCulture ne suffit pas) ' Avec ces 2 paramètres, Drôle est bien trouvé, et il est bien distinct de Drole 'Private m_htMots As New Hashtable( _ ' CaseInsensitiveHashCodeProvider.Default, _ ' CaseInsensitiveComparer.Default) ' BC40000 Private m_htMots As New Hashtable(m_styleCompare) ' Si Unicode alors conserver les accents et tous les caractères exotiques Public m_bOptionTexteUnicode As Boolean Private Const iMasqueOptionUnicode% = 1 Private Const iMasqueOptionAccent% = 2 Public m_bOccurrencesEnGras As Boolean = False Public m_bOccurrencesEnCouleurs As Boolean = True Public m_sCouleursHtml$ = sCouleursHtmlDef Public m_bIndexerChapitre As Boolean = False Public m_sChapitrage$ = sChapitrageDef Public m_sChapitrageMdb$ = sChapitrageMdbDef Public m_sChapitrageXL$ = sChapitrageXLDef 'Public m_bAfficherChapitre As Boolean = True ' Utile ? ' Afficher aussi les chapitres dans les index. alphab. et fréq. Public m_bAfficherChapitreIndex As Boolean = False ' Afficher les n° de § et de phrase global sinon local à chaque document ' Note : si on affiche les n° local, on ne peut pas restaurer la position ' du curseur Public m_bNumerotationGlobale As Boolean = True #End Region #Region "Déclarations" Private Const rVersionFichierVBTxtFndIdx10! = 1.0! Private Const rVersionFichierVBTxtFndIdx! = 1.15! ' Fichiers de sauvegarde de l'index Private Const sExtVBTF$ = ".idx" '".dat" Private Const sFichierVBTxtFndIdxDef$ = "VBTextFinder" & sExtVBTF ' Sauvegarde en cours Private Const sMsgGestionIndex$ = "Gestion du fichier d'index " & sFichierVBTxtFndIdxDef Private m_sCheminVBTxtFndTmp$, m_sCheminVBTxtFndBak$, m_sCheminVBTxtFndIdx$ Private m_sCheminFichierIndex$ ' Chemin complet avec extension du fichier index Private m_sCheminFichierIni$ Private m_bFichierIndexDef As Boolean ' Fabrication du document index Private Const sFichierVBTxtFnd$ = "VBTextFinder" Private Const sFichierVBTxtFndAlphab$ = "VBTextFinderAlphab" Private Const sFichierVBTxtFndFreq$ = "VBTextFinderFreq" Private Const sFichierVBTxtFndMotsCles$ = "VBTextFinderMotsCles" Private Const sFichierVBTxtFndTout$ = "VBTextFinderTout" Private Const sFichierIni$ = "VBTextFinder" Private Const sTriDef$ = sIndexAlpha Private Const sAfficherDef$ = sAfficherPhrase Private Const sCodeDocDef$ = "Doc n°" ' Booléen pour pouvoir interrompre une longue opération Private m_bInterrompre As Boolean Private m_bSablierDesactive As Boolean Private m_msgDelegue As clsMsgDelegue Private m_sListeSeparateursMot$, m_sListeSeparateursPhrase$ ' Booléen pour savoir si l'index est modifié, ' auquel cas il doit être sauvé lors de la fermeture de l'application Private m_bIndexModifie As Boolean ' Collection de phrases indexées par leur numéro (un tableau suffirait dans ce cas) ' Par rapport à une Collection VB6 , les indices d'une ArrayList commencent à 0 au lieu de 1 Private m_colPhrases As New ArrayList 'Collection ' Collection des documents indexés Private m_colDocs As New Collection ' Hashtable : perd l'ordre : dommage ! 'Private m_colDocs As Collections.Specialized.NameObjectCollectionBase ' Hashtable+ArrayList Private m_colDocsIni As New Collection ' Reste des codes doc dans le ini Const sTagUnicodeIni$ = "Unicode" 'Private m_colChapitres As New Collection ' sCleChapitre -> clsChapitre Private m_sbChapitres As New StringBuilder Private m_htDico As Hashtable Private tsDiffTps As New TimeSpan ' Conversion à la volée : noter si le fichier txt converti existait avant ' pour savoir s'il faut le supprimer en quittant ' Liste des fichiers txt à supprimer en quittant Private m_alsCheminsFichierTxt As New ArrayList Private m_sMemExpression$ = "" Private m_alExpressions As ArrayList ' Tous ces n° sont globaux sur l'ensemble des documents Private m_iNumParagSel%, m_iNumPhraseSel%, m_iNumCarSel%, m_iLongSel% Private Const sIndicParag$ = "§ n°" Private Const sCarParag$ = "§" Private Const sIndicPhrase$ = "Ph. n°" Private Const sSepIni$ = "|" ' ":" Public m_bAuMoinsUnTxtUnicode As Boolean = False ' INFORMATION : Le texte contient des caractères Unicode et l'option n'est pas activée ' (ces caractères seront remplacés par des signes '?') Public m_bAvertAuMoinsUnTxtUnicode As Boolean = False ' Information : Le texte ne contient pas de caractères Unicode (alors que l'option est activée) Public m_bInfoAuMoinsUnTxtNonUnicode As Boolean = False #End Region #Region "Initialisation et gestion du formulaire" Public Sub Initialiser(msgDelegue As clsMsgDelegue, _ ByRef ctrlLstAfficher As System.Windows.Forms.ListBox, _ ByRef ctrlTypeIndex As System.Windows.Forms.ListBox, iTypeIndexSelect%) ' 23/11/2018 m_bAuMoinsUnTxtUnicode = False m_bAvertAuMoinsUnTxtUnicode = False m_bInfoAuMoinsUnTxtNonUnicode = False Me.m_msgDelegue = msgDelegue ' Initialisation des contrôles de l'interface ctrlLstAfficher.Items.Add(sAfficherPhrase) ctrlLstAfficher.Items.Add(sAfficherParag) ctrlLstAfficher.Items.Add(sAfficherParagPM1) ctrlLstAfficher.Items.Add(sAfficherParagPM2) ctrlLstAfficher.Items.Add(sAfficherParagPM3) ctrlLstAfficher.SetSelected(0, True) ctrlTypeIndex.Items.Add(sIndexAlpha) ctrlTypeIndex.Items.Add(sIndexFreq) ctrlTypeIndex.Items.Add(sIndexMotsCles) ctrlTypeIndex.Items.Add(sIndexCitations) ctrlTypeIndex.Items.Add(sIndexSimple) ctrlTypeIndex.Items.Add(sIndexSimpleComparer) ctrlTypeIndex.Items.Add(sIndexTout) If Not bSupprimerEspInsec Then ctrlTypeIndex.Items.Add(sIndexEspacesInsecables) ctrlTypeIndex.Items.Add(sIndexEspacesInsecablesAVerifier) End If ctrlTypeIndex.Items.Add(sIndexMajuscules) ' 26/03/2016 ctrlTypeIndex.Items.Add(sIndexAccents) ' 06/06/2019 'If bDebug Then ctrlTypeIndex.Items.Add(sIndexNGrammes) 'ctrlTypeIndex.SetSelected(0, True) ctrlTypeIndex.SetSelected(iTypeIndexSelect, True) ' Chemin par défaut s'il n'y a pas d'arg en ligne de cmd m_sCheminFichierIndex = Application.StartupPath & "\" & sFichierVBTxtFndIdxDef m_bFichierIndexDef = True Dim sArgument$ ' Extraire les options passées en argument de la ligne de commande ' Ne fonctionne pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command ' Extraire l'option passée en argument de la ligne de commande Dim sNomFichierSansExt$ = "" If sArg0.Length > 0 Then Dim asArgs$() = asArgLigneCmd(sArg0) If asArgs.Length > 0 Then sArgument = asArgs(0) If bDossierExiste(sArgument) Then ' Si le dossier existe, alors cela signifie qu'il s'agit d'un dossier ' dans ce cas indexer tous les documents du dossier m_sCheminDossierCourant = sEnleverSlashFinal(sArgument) sNomFichierSansExt = sNomDossierFinal(sArgument) GoTo Suite End If If bFichierExiste(sArgument) Then Dim sExt$ = IO.Path.GetExtension(sArgument).ToLower If sExt = sExtVBTF Then m_sCheminFichierIndex = sArgument : m_bFichierIndexDef = False Else 'If sExt = sExtTxt Or sExt = sExtDoc Or sExt.StartsWith(sExtHtm) Then ' 29/05/2015 Accepter tout types de fichier m_bModeDirect = True m_sCheminFichierTxtDirect = sArgument m_sCheminFichierIndex = _ sExtraireChemin(m_sCheminFichierTxtDirect) & "\" & _ sFichierVBTxtFndIdxDef End If Else MsgBox("Impossible de trouver le fichier :" & vbLf & _ sArgument, MsgBoxStyle.Critical, _ "Passage d'un fichier au démarrage de VBTextFinder") End If End If End If Dim sNomFichier$ = "", sExtension$ = "" m_sCheminDossierCourant = sExtraireChemin(m_sCheminFichierIndex, sNomFichier, _ sExtension, sNomFichierSansExt) Suite: m_sCheminVBTxtFndTmp = m_sCheminDossierCourant & "\" & sNomFichierSansExt & ".tmp" m_sCheminVBTxtFndBak = m_sCheminDossierCourant & "\" & sNomFichierSansExt & ".bak" m_sCheminVBTxtFndIdx = m_sCheminDossierCourant & "\" & sNomFichierSansExt & sExtVBTF m_sCheminFichierIni = m_sCheminDossierCourant & "\" & sFichierIni & ".ini" Me.iNbPhrasesG = 0 Dim sChemin = Application.StartupPath & Config.sCheminSeparateursMot 'MsgBox("Chemin sep mot : " & sChemin) If bFichierExiste(sChemin) Then Me.m_sListeSeparateursMot = sLireFichier(sChemin) ' Dans le fichier, tous les caractères sont bien conservés, sauf l'espace insécable ' 20/09/2009 Maintenant c'est nécessaire d'inclure l'espace insécable, car il est conservé Doc->Txt Me.m_sListeSeparateursMot &= Chr(iCodeASCIIEspaceInsecable) Else Me.m_sListeSeparateursMot = Config.sListeSeparateursMot Me.m_sListeSeparateursMot &= _ Chr(iCodeASCIITabulation) & _ Chr(iCodeASCIIGuillemet) & _ Chr(iCodeASCIIGuillemetOuvrant) & Chr(iCodeASCIIGuillemetFermant) & _ Chr(iCodeASCIIEspaceInsecable) ' 20/09/2009 Maintenant c'est nécessaire d'inclure l'espace insécable, car il est conservé Doc->Txt End If ' 15/09/2018 If Me.m_bOptionTexteUnicode Then Me.m_sListeSeparateursMot &= ChrW(iCodeUTF16EspaceFineInsecable) Me.m_sListeSeparateursMot &= ChrW(iCodeUTF16EspaceInsecable) ' 13/07/2019 End If sChemin = Application.StartupPath & Config.sCheminSeparateursPhrase If bFichierExiste(sChemin) Then Me.m_sListeSeparateursPhrase = sLireFichier(sChemin) Else Me.m_sListeSeparateursPhrase = Config.sListeSeparateursPhrase End If sChemin = Application.StartupPath & Config.sCheminChapitrage If bFichierExiste(sChemin) Then Me.m_sChapitrage = sLireFichier(sChemin) sChemin = Application.StartupPath & Config.sCheminChapitrageExcel If bFichierExiste(sChemin) Then Me.m_sChapitrageXL = sLireFichier(sChemin) sChemin = Application.StartupPath & Config.sCheminChapitrageAccess If bFichierExiste(sChemin) Then Me.m_sChapitrageMdb = sLireFichier(sChemin) Me.tsDiffTps = New TimeSpan(0) End Sub Public Function bQuitter() As Boolean Dim lNbDocs As Integer lNbDocs = Me.m_colDocs.Count() Dim iReponse% ' As Short If lNbDocs > 0 And m_bIndexModifie And Not m_bModeDirect Then iReponse = MsgBox("Voulez-vous sauvegarder l'index de VBTextFinder :" & vbLf & _ m_sCheminVBTxtFndIdx & " ?" & vbLf & _ "(nombre de documents : " & lNbDocs & ")", _ MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question, sMsgGestionIndex) If iReponse = MsgBoxResult.Cancel Then Return False If iReponse = MsgBoxResult.No Then GoTo Fin If m_bIndexModifie Then ' Si la liste des fichiers ini a été modifiée, resauver l'index If Not bSauvegarderIndex(m_sCheminVBTxtFndIdx) Then Return False Else ' Sinon valider la copie temporaire en copie de sauvegarde pour de bon ' (ou sinon sauvegarder simplement l'index ' si l'option bSauvegardeSecurite = False) If Not bValiderSauvegardeTmp() Then Return False End If End If Fin: Sablier() AfficherMessage("Désallocation des mots en mémoire vive...") Me.m_htMots = Nothing GC.Collect() AfficherMessage("Désallocation des phrases en mémoire vive...") Me.m_colPhrases = Nothing 'Me.m_colChapitres = Nothing Me.m_colDocs = Nothing GC.Collect() If Me.m_alsCheminsFichierTxt.Count > 0 AndAlso _ MsgBoxResult.Yes = MsgBox( _ "Voulez-vous supprimer le(s) fichier(s) texte (.txt) temporaire(s) ?", _ MsgBoxStyle.YesNo Or MsgBoxStyle.Question, sTitreMsg) Then Dim sCheminFichier$ For Each sCheminFichier In Me.m_alsCheminsFichierTxt bSupprimerFichier(sCheminFichier) Next End If Sablier(bDesactiver:=True) bQuitter = True End Function Public Sub Interrompre() ' VB est un langage événementiel multi-thread : deux fonctions peuvent très bien ' fonctionner simultanément, on se sert de cela pour pouvoir interrompre une ' opération en cours assez longue (il peut même arriver qu'une même fonction ' en cours soit ré-appelée : ré-entrance) m_bInterrompre = True End Sub Private Function bInterruption() As Boolean ' Laisser du temps pour le traitement des messages : affichage du message et ' traitement du clic éventuel sur le bouton Interrompre Application.DoEvents() bInterruption = m_bInterrompre End Function Private Sub AfficherMessage(sMsg$) Me.m_msgDelegue.AfficherMsg(sMsg) ' Rétablir le curseur courant au cas où l'affichage l'aurait fait perdre Sablier(Me.m_bSablierDesactive) End Sub Public Sub Sablier(Optional bDesactiver As Boolean = False) Me.m_bSablierDesactive = bDesactiver Me.m_msgDelegue.Sablier(bDesactiver) End Sub #End Region #Region "Indexation" Public Function bConvertirDocEnTxt(ByRef sCheminFichierSelect$, _ bVerifierUnicode As Boolean, ByRef bTxtUnicode As Boolean, ByRef bAvertUnicode As Boolean, ByRef bInfoTxtNonUnicode As Boolean, bSablier As Boolean) As Boolean ' 23/11/2018 bAvertUnicode = False bInfoTxtNonUnicode = False bTxtUnicode = False Dim sExtension$ = "", sNomFichier$ = "" Dim sChemin$, sCheminFichierTxt$ sChemin = sExtraireChemin(sCheminFichierSelect, sNomFichier, sExtension) sExtension = sExtension.ToLower ' On laisse le fichier inchangé si on ne peut pas le convertir avec Word If Not (sExtension = sExtDoc OrElse sExtension.StartsWith(sExtHtm)) Then _ bConvertirDocEnTxt = True : Exit Function sCheminFichierTxt = sChemin & "\" & _ Left(sNomFichier, Len(sNomFichier) - Len(sExtension)) & sExtTxt ' Si le fichier n'existait pas avant, l'ajouter à la liste des fichiers ' à supprimer en quittant If Not bFichierExiste(sCheminFichierTxt) Then _ Me.m_alsCheminsFichierTxt.Add(sCheminFichierTxt) ' Convertir un fichier .doc ou .html en .txt If bSablier Then Sablier() bConvertirDocEnTxt = bConvertirDocEnTxt2(sCheminFichierSelect, _ sCheminFichierTxt, m_sCheminDossierCourant, Me.m_msgDelegue, _ m_bOptionTexteUnicode, bVerifierUnicode, bTxtUnicode, bAvertUnicode, bInfoTxtNonUnicode) If bConvertirDocEnTxt Then AfficherMessage("Conversion en .txt terminée.") sCheminFichierSelect = sCheminFichierTxt ' 23/11/2018 If bTxtUnicode Then m_bAuMoinsUnTxtUnicode = True If bAvertUnicode Then m_bAvertAuMoinsUnTxtUnicode = True If bInfoTxtNonUnicode Then m_bInfoAuMoinsUnTxtNonUnicode = True End If If bSablier Then Sablier(bDesactiver:=True) End Function Public Function bIndexerDocuments(sCheminFichier$, bVerifierUnicode As Boolean) As Boolean ' Indexer un ou plusieurs documents bIndexerDocuments = False Sablier() Dim dTpsDeb As DateTime = Now If sCheminFichier.IndexOfAny("*?".ToCharArray()) > -1 Then m_bModeDirect = False Dim sRep$ = IO.Path.GetDirectoryName(sCheminFichier) Dim sFiltre$ = IO.Path.GetFileName(sCheminFichier) Dim aFichiers$() = IO.Directory.GetFiles(sRep, sFiltre) Dim i%, sFichier$, iNbFichers% iNbFichers = aFichiers.GetUpperBound(0) For i = 0 To iNbFichers sFichier = aFichiers(i) ' Convertir le fichier en .txt si son extension ' est celle d'un document convertible (.doc, .html ou .htm) ' Le fichier peut être supprimé entre temps ' et ne pas ré-indexer les index Dim sNomFichier$ = IO.Path.GetFileName(sFichier) If sNomFichier.StartsWith(sPrefixeIndex) Then Continue For If bFichierExiste(sFichier) AndAlso _ Left$(sNomFichier, Len(sFichierVBTxtFnd)).ToLower <> _ sFichierVBTxtFnd.ToLower Then Dim bFichierTxtInexistant As Boolean = False Dim bAvertUnicode As Boolean = False Dim bInfoTxtNonUnicode As Boolean = False Dim bTxtUnicode As Boolean = False If Not bConvertirDocEnTxt(sFichier, bVerifierUnicode, bTxtUnicode, bAvertUnicode, bInfoTxtNonUnicode, bSablier:=False) Then GoTo Fin 'If bTxtUnicode Then ' Debug.WriteLine(sNomFichier) 'End If If bTxtUnicode Then m_bAuMoinsUnTxtUnicode = True If bAvertUnicode Then m_bAvertAuMoinsUnTxtUnicode = True If bInfoTxtNonUnicode Then m_bInfoAuMoinsUnTxtNonUnicode = True Dim sNumFichier$ = "Doc n°" & i + 1 & " / " & iNbFichers + 1 & " : " ' Le document peut être déjà indexé bIndexerDocument(sFichier, bTxtUnicode, sNumFichier) If m_bInterrompre Then GoTo Fin If m_msgDelegue.m_bAnnuler Then GoTo Fin ' Pas tjrs très réactif ? End If Next i Else ' Ici l'info. n'est pas connue, on le sait lorsqu'on conv. le doc en txt Const bTxtUnicode As Boolean = False If Not bIndexerDocument(sCheminFichier, bTxtUnicode) Then GoTo fin End If Dim dTpsFin As DateTime = Now Me.tsDiffTps = dTpsFin.Subtract(dTpsDeb) If m_bModeDirect Then GoTo FinOk EcrireListeDocumentsIndexesIni(bAfficherIni:=False) ' Faire une sauvegarde de l'index dans le fichier VBTxtFnd.tmp ' si l'option est activée If bSauvegardeSecurite Then bSauvegarderIndex(m_sCheminVBTxtFndTmp) AfficherFichierIni() FinOk: bIndexerDocuments = True AfficherMessage(sMsgOperationTerminee) Fin: Sablier(bDesactiver:=True) If m_bInterrompre Then AfficherMessage("Indexation interrompue.") End Function Private Function bIndexerDocument(sCheminFichier$, bTxtUnicode As Boolean, _ Optional sNumFichier$ = "") As Boolean ' Indexer un document If Not bFichierExiste(sCheminFichier) Then Return False m_bInterrompre = False ' Générer un code document par défaut Dim sCleDoc$ = sCleDocDefaut() ' Ajouter le document dans la collection If Not bAjouterDocument(sCleDoc, sCleDoc, sCheminFichier, bTxtUnicode) Then Return False ' Voir s'il y a code document dans la liste éditable dans le fichier ini LireListeDocumentsIndexesIni() Dim oDoc As clsDoc = Nothing If m_bIndexerChapitre Then If m_colDocs.Contains(sCleDoc) Then oDoc = DirectCast(m_colDocs.Item(sCleDoc), clsDoc) Dim sUnicode$ = "" If oDoc.bTxtUnicode Then sUnicode = ":Unicode" ' 24/05/2019 m_sbChapitres.AppendLine(vbCrLf & oDoc.sChemin & " (" & oDoc.sCodeDoc & sUnicode & ") :") End If End If m_bIndexModifie = True ' Modification de l'index courant m_sMemExpression = "" ' La précédente recherche d'expression doit être refaite If Not bIndexerDocumentInterne(sCheminFichier, sNumFichier, sCleDoc, m_bIndexerChapitre, oDoc) Then Return False bIndexerDocument = True End Function Private Function bIndexerDocumentInterne(sCheminFichier$, sNumFichier$, sCleDoc$, Optional bIndexerChapitre As Boolean = False, Optional oDoc As clsDoc = Nothing) As Boolean Dim sCodeChapitre$ = "" Dim iMaxTypeChapitrage% = 0 Dim asTypesChapitrages$() = Nothing Dim iMaxTypeChapitrageXL% = 0 Dim asTypesChapitragesXL$() = Nothing Dim iMaxTypeChapitrageMdb% = 0 Dim asTypesChapitragesMdb$() = Nothing Dim iNumChapitre% = 0 Dim bTypeChapExclusif As Boolean = False If bIndexerChapitre Then ParserChapitrage( asTypesChapitrages, iMaxTypeChapitrage, asTypesChapitragesXL, iMaxTypeChapitrageXL, asTypesChapitragesMdb, iMaxTypeChapitrageMdb) End If Dim sMot$, sLigne$ Dim bNouvParag As Boolean Dim iNbLignes% Dim acSepPhrase() As Char = Me.m_sListeSeparateursPhrase.ToCharArray Dim acSepMot() As Char = Me.m_sListeSeparateursMot.ToCharArray Dim sCle$, sPhrasePonct$ Dim oPhrase As clsPhrase Dim oMot As clsMot Dim bCleExiste As Boolean, bPremPhrase As Boolean Dim asPhrases$() Dim iPosDebPhrase%, iFinLigne%, iNumPhrase%, j%, iNbPhrases% Dim iPosDebPhraseSuiv% Dim iNbMotsL%, iNbParagL%, iNbPhrasesL%, iDebRech% iNbMotsL = 0 : iNbParagL = 0 : iNbPhrasesL = 0 AfficherMessage("Lecture du document en cours... " & sDossierParent(sCheminFichier)) Dim asLignes() = asLireFichier(sCheminFichier) Dim iNbLignesTot = asLignes.Length For Each sLigne In asLignes ' Afficher la progression de la lecture iNbLignes += 1 If (iNbLignes Mod iModuloAvanvement) = 0 Then AfficherMessage(sNumFichier & "Indexation en cours... " & _ Int(100.0! * iNbLignes / iNbLignesTot) & "%") If m_bInterrompre Then Exit For End If bNouvParag = True If sLigne.Length = 0 Then GoTo LigneSuivante asPhrases = sLigne.Split(acSepPhrase) iNbPhrases = asPhrases.GetLength(0) iFinLigne = sLigne.Length iDebRech = 1 bPremPhrase = False For iNumPhrase = 0 To iNbPhrases - 1 Dim sPhrase$ = asPhrases(iNumPhrase).TrimStart If sPhrase.Length = 0 Then GoTo PhraseSuivante ' Cas d'une phrase composée seulement de guillemets iPosDebPhrase = InStr(iDebRech, sLigne, sPhrase) If iPosDebPhrase = 0 Then GoTo PhraseSuivante ' Ne pas compter les paragraphes vides If bNouvParag Then bNouvParag = False Me.iNbParagG += 1 iNbParagL += 1 End If ' Recherche de la phrase avec sa ponctuation iPosDebPhraseSuiv = iFinLigne + 1 If iNumPhrase < iNbPhrases - 1 Then For j = iNumPhrase + 1 To iNbPhrases - 1 Dim sPhraseSuiv$ = asPhrases(j).TrimStart If sPhraseSuiv.Length = 0 Then GoTo PhraseSuivante0 ' 19/09/2009 Le début de la phrase suivante doit au moins ' etre supérieur à la longueur de la phrase précédante 'Dim iPosDebPhraseSuiv_old = InStr(iDebRech + 1, sLigne, sPhraseSuiv) Dim iLenPreced% = asPhrases(j - 1).Length iPosDebPhraseSuiv = InStr(iDebRech + iLenPreced, sLigne, sPhraseSuiv) If iPosDebPhraseSuiv > iPosDebPhrase Then Exit For PhraseSuivante0: Next j If iPosDebPhraseSuiv <= iPosDebPhrase Then iPosDebPhraseSuiv = iFinLigne + 1 End If ' Tant que l'on n'a pas la première phrase, commencer au début If Not bPremPhrase Then iPosDebPhrase = 1 sPhrasePonct = sLigne.Substring(iPosDebPhrase - 1, iPosDebPhraseSuiv - iPosDebPhrase) ' Supprimer l'espace à gauche, car il est présent en double via le split ' (sauf la première phrase) If bPremPhrase Then sPhrasePonct = sPhrasePonct.TrimStart bPremPhrase = True iDebRech = iPosDebPhraseSuiv ' Ajouter une phrase à la liste des phrases indexées Me.iNbPhrasesG += 1 ' Nombre de phrases globales iNbPhrasesL += 1 ' Nombre de phrases du document ' 19/06/2010 Analyse du chapitrage If bIndexerChapitre AndAlso iNumPhrase = 0 Then GestionChapitrage(sLigne, sPhrasePonct, sCleDoc, oDoc, _ iMaxTypeChapitrage, asTypesChapitrages, _ iNumChapitre, sCodeChapitre, bTypeChapExclusif, _ iMaxTypeChapitrageXL, asTypesChapitragesXL, _ iMaxTypeChapitrageMdb, asTypesChapitragesMdb) End If ' iNbPhrasesG : Numéro de la phrase oPhrase = New clsPhrase With { .iNumPhraseG = Me.iNbPhrasesG, .iNumPhraseL = iNbPhrasesL, .sClePhrase = Me.iNbPhrasesG.ToString, .iNumParagrapheL = iNbParagL, .iNumParagrapheG = iNbParagG, .sCleDoc = sCleDoc, .sCodeChapitre = sCodeChapitre } ' 02/08/2010 Remplacer les espaces insécables pour faciliter les recherches If bSupprimerEspInsec Then oPhrase.sPhrase = sPhrasePonct.Replace(Chr(iCodeASCIIEspaceInsecable), " "c) ' 15/09/2018 If Me.m_bOptionTexteUnicode Then oPhrase.sPhrase = oPhrase.sPhrase.Replace( _ ChrW(iCodeUTF16EspaceFineInsecable), " "c) oPhrase.sPhrase = oPhrase.sPhrase.Replace( _ ChrW(iCodeUTF16EspaceInsecable), " "c) ' 13/07/2019 End If Else oPhrase.sPhrase = sPhrasePonct End If m_colPhrases.Add(oPhrase) ' ArrayList Dim asMots$() = asPhrases(iNumPhrase).Split(acSepMot) ' 20/11/2016 Le découpage fonctionne très bien, on ne trouve jamais aucune différence 'Dim asMots2$() = asPhrases(iNumPhrase).VBSplit(acSepMot) 'Dim bEgal = Linq.Enumerable.SequenceEqual(asMots, asMots2) 'If Not bEgal Then ' MsgBox("Différence trouvée : [" & asPhrases(iNumPhrase) & "]") ' Return False 'End If For Each sMot In asMots If sMot.Length = 0 Then GoTo MotSuivant Me.iNbMotsG += 1 iNbMotsL += 1 ' Indexer les mots pour ne conserver que les mots distincts ' D'abord vérifier rapidement si le mot est indexé tel quel ' Les mots accentués sont distingués sCle = sMot bCleExiste = Me.m_htMots.ContainsKey(sCle) ' S'il n'est pas indexé tel quel, vérifier s'il est indexé ' sans les accents si c'est l'option choisie ' (si le mot a été trouvé tel quel, c'est qu'il n'avait pas d'accent) If Not m_bIndexerAccents And Not bCleExiste Then ' Les mots accentués ne sont pas distingués sCle = sEnleverAccents(sMot) If sCle <> sMot Then bCleExiste = Me.m_htMots.ContainsKey(sCle) End If If bCleExiste Then ' DirectCast = Casting direct comme CType mais sans conversion oMot = DirectCast(Me.m_htMots.Item(sCle), clsMot) ' Mot déjà existant : incrémenter le nombre d'occurrences With oMot .iNbOccurrences += 1 .aiNumPhrase.Add(Me.iNbPhrasesG) End With Else ' Clé absente dans la collection, on ajoute le mot oMot = New clsMot With oMot ' On peut laisser les accents ici, contrairement à la clé .sMot = sMot.ToLower .iNbOccurrences = 1 .aiNumPhrase.Add(Me.iNbPhrasesG) End With Me.m_htMots.Add(sCle, oMot) ' Ajout du mot dans la Hastable End If MotSuivant: Next sMot PhraseSuivante: Next iNumPhrase LigneSuivante: Next sLigne Return True End Function Private Sub ParserChapitrage( ByRef asTypesChapitrages$(), ByRef iMaxTypeChapitrage%, ByRef asTypesChapitragesXL$(), ByRef iMaxTypeChapitrageXL%, ByRef asTypesChapitragesMdb$(), ByRef iMaxTypeChapitrageMdb%) asTypesChapitrages = m_sChapitrage.Split(";"c) Dim iMax% = asTypesChapitrages.GetUpperBound(0) ' Types + Codes Dim iNbChap% = (iMax + 1) \ 2 ' Types seuls iMaxTypeChapitrage = iNbChap - 1 asTypesChapitragesXL = m_sChapitrageXL.Split(";"c) Dim iMaxXL% = asTypesChapitragesXL.GetUpperBound(0) Dim iNbChapXL% = (iMaxXL + 1) \ 2 iMaxTypeChapitrageXL = iNbChapXL - 1 asTypesChapitragesMdb = m_sChapitrageMdb.Split(";"c) Dim iMaxMdb% = asTypesChapitragesMdb.GetUpperBound(0) Dim iNbChapMdb% = (iMaxMdb + 1) \ 2 iMaxTypeChapitrageMdb = iNbChapMdb - 1 ' 01/05/2012 Arrondir à pair, s'il manque le couple Chapitre-Code chapitre iMax = iNbChap * 2 - 1 iMaxXL = iNbChapXL * 2 - 1 iMaxMdb = iNbChapMdb * 2 - 1 Dim iSupplement% = iNbChapXL + iNbChapMdb If iSupplement > 0 Then ' Déplacer le chapitrage normal à la fin (l'exclusif est prioritaire) Dim iMemMax% = iMax Dim iMemNbChap% = iNbChap iNbChap += iSupplement iMaxTypeChapitrage = iNbChap - 1 iMax = iNbChap * 2 - 1 Dim iDec% = (iNbChapXL + iNbChapMdb) * 2 ReDim Preserve asTypesChapitrages(0 To iMax) For i = iMemMax To 0 Step -1 asTypesChapitrages(iDec + i) = asTypesChapitrages(i) Next ' Copier le chapitrage Excel au début For i = 0 To iMaxXL asTypesChapitrages(i) = asTypesChapitragesXL(i) Next ' Ensuite copier le chapitrage Access à la suite For i = iMaxXL + 1 To iMaxXL + 1 + iMaxMdb asTypesChapitrages(i) = asTypesChapitragesMdb(i - (iMaxXL + 1)) Next End If End Sub Private Sub GestionChapitrage(sLigne$, sPhrasePonct$, _ sCleDoc$, oDoc As clsDoc, _ iMaxTypeChapitrage%, asTypesChapitrages$(), _ ByRef iNumChapitre%, ByRef sCodeChapitre$, _ ByRef bTypeChapExclusif As Boolean, _ iMaxTypeChapitrageXL%, asTypesChapitragesXL$(), _ iMaxTypeChapitrageMdb%, asTypesChapitragesMdb$()) ' Gestion du chapitrage (le fait de noter la position d'un mot dans ' un chapitre précis d'un document indexé) ' Si la ligne contient des tabulations ou plusieurs espaces consécutifs : ' table des matières : ignorer Dim iPosTab% = sLigne.IndexOf(vbTab) Dim iPos2Esp% = sLigne.IndexOf(" ") Dim bTableDesMatieres As Boolean = False If iPosTab <> -1 Or iPos2Esp <> -1 Then bTableDesMatieres = True If bTableDesMatieres Then Exit Sub Dim cEspaceInsec As Char = Chr(iCodeASCIIEspaceInsecable) For i = 0 To iMaxTypeChapitrage Dim sTypeChap$ = asTypesChapitrages(i * 2) Dim sCodeChap$ = asTypesChapitrages(i * 2 + 1) If Not sPhrasePonct.StartsWith(sTypeChap, m_styleCompare2) Then Continue For ' Détection d'un type de chapitre à ignorer If sCodeChap.StartsWith("-") Then Exit For Dim sReste$ = sPhrasePonct.Substring(sTypeChap.Length) Dim bTypeChapExclusifMaintenant As Boolean = False For j = 0 To iMaxTypeChapitrageXL If sTypeChap = asTypesChapitragesXL(j * 2) Then bTypeChapExclusifMaintenant = True Exit For End If Next If Not bTypeChapExclusifMaintenant Then For j = 0 To iMaxTypeChapitrageMdb If sTypeChap = asTypesChapitragesMdb(j * 2) Then bTypeChapExclusifMaintenant = True Exit For End If Next End If If bTypeChapExclusifMaintenant Then bTypeChapExclusif = True Else ' Ne pas chercher les autres types de chapitres dans ce cas ' (éviter de détecter des chapitres intempestifs dans ' le contenu Access ou Excel) If bTypeChapExclusif Then Exit For End If ' Il faut qualifier un type de chapitre : n°, ... If sReste.Length = 0 Then Exit For ' Autoriser le numChapitre à coller au chapitre, ' à condition qu'il soit numérique ' Commencer par vérifier si le numChapitre est collé Dim iPosEspace% = sReste.IndexOf(" ") Dim iPosEspaceInsec% = sReste.IndexOf(cEspaceInsec) Dim bNumChapColle As Boolean = True If (iPosEspace = 0 Or iPosEspaceInsec = 0) Then bNumChapColle = False If bNumChapColle Then ' Ensuite vérifier si le 1er car. qui suit est numérique Dim cCar1 As Char = sReste.Chars(0) Dim b1erCarNum As Boolean = bCarNumerique(cCar1) ' Si le 1er car. n'est pas numérique : refuser (partie de mot) If Not b1erCarNum Then Continue For End If Dim sNumSection$ = "" If iPosEspace = 0 Then ElseIf iPosEspaceInsec = 0 Then ElseIf iPosEspace > 0 Then '-1 Then sNumSection = sReste.Substring(0, iPosEspace) ElseIf iPosEspaceInsec > 0 Then '-1 Then sNumSection = sReste.Substring(0, iPosEspaceInsec) Else sNumSection = sReste End If ' Créer une numérotation automatique si pas d'autre solution Dim bNumAuto As Boolean = False If sNumSection.Trim.Length = 0 Then Dim sReste2$ = sRognerDernierCar(sReste.Trim, ":") ' Vérifier si la longueur totale de la numérotation ' n'est pas trop grande (sinon on garde) sNumSection = sReste2.Trim If sNumSection.Length > iNbCarChapitreMax Then bNumAuto = True End If If bNumAuto Then ' Créer une numérotation automatique iNumChapitre += 1 sNumSection = iNumChapitre.ToString Else sNumSection = sRognerDernierCar(sNumSection, ".") sNumSection = sRognerDernierCar(sNumSection, ":") End If sCodeChapitre = sCodeChap & sNumSection.Trim Dim chap As New clsChapitre chap.sCodeChapitre = sCodeChapitre chap.sCleDoc = sCleDoc chap.sCodeDoc = sCleDoc ' Pas encore éditée pour le moment chap.sChapitre = sLigne chap.sCle = sCleDoc & ":" & chap.sCodeChapitre If oDoc.colChapitres.Contains(chap.sCle) Then ' Si la clé existe déjà, alors ignorer le chapitrage ' (c'est sans doute une occurrence parasite dans le texte) Exit For End If oDoc.colChapitres.Add(chap, chap.sCle) m_sbChapitres.Append(sCodeChapitre) m_sbChapitres.AppendLine(" : " & sLigne) Exit For Next End Sub Public Function sCleDocDefaut$() ' Générer un code document par défaut sCleDocDefaut = sCodeDocDef & Me.m_colDocs.Count() + 1 End Function Public Function bCleDocExiste(sCleDoc$) As Boolean ' Vérifier si un code document est déjà utilisé pour un des documents indexés ' On peut laisser un code document vide : un code numéroté sera généré par défaut If sCleDoc = "" Then Return False If Me.m_colDocs.Count = 0 Then Return False 'bCleDocExiste = m_colDocs.ContainsKey(sCleDoc) ' Hastable Return m_colDocs.Contains(sCleDoc) ' Collection : Contains a été ajouté depuis VB6 ! End Function Private Function sLireCleDocPhrase$(iNumPhraseG%, _ Optional ByRef sCodeChapitre$ = "") ' Retourner le code document d'un numéro de phrase global Dim oPhrase As clsPhrase oPhrase = DirectCast(m_colPhrases.Item(iNumPhraseG - 1), clsPhrase) sLireCleDocPhrase = oPhrase.sCleDoc sCodeChapitre = oPhrase.sCodeChapitre End Function Private Function sLireCodeDoc$(sCleDoc$) ' Retourner le code document de la clé d'un document ' util pour trouver le code document via une clé de document ' associée à une phrase Dim oDoc As clsDoc oDoc = DirectCast(m_colDocs.Item(sCleDoc), clsDoc) sLireCodeDoc = oDoc.sCodeDoc End Function Public Function iNbDocumentsIndexes%() iNbDocumentsIndexes = Me.m_colDocs.Count() End Function Public Sub ListerDocumentsIndexes(ByRef CtrlResultat As Windows.Forms.TextBox, _ Optional bListerPhrases As Boolean = True, _ Optional bHtml As Boolean = False) ' Afficher la liste des documents indexés AfficherMessage("Ecriture du rapport d'indexation...") Dim sbResultat As New StringBuilder ' Utiliser le format de présentation en français, ' en utilisant les préférences de l'utilisateur le cas échéant Dim nfi As System.Globalization.NumberFormatInfo = _ New System.Globalization.CultureInfo("fr-FR", useUserOverride:=True).NumberFormat nfi.NumberDecimalDigits = 0 ' Afficher des nombres entiers, sans virgule If m_bAvertAuMoinsUnTxtUnicode Then ' 23/11/2018 ' Au moins un document ici : sbResultat.AppendLine("INFORMATION : Le texte contient des caractères Unicode et l'option n'est pas activée (ces caractères seront remplacés par des signes '?').") sbResultat.AppendLine("") End If If m_bInfoAuMoinsUnTxtNonUnicode Then 'sbResultat.AppendLine("Information : Le texte ne contient pas de caractères Unicode.") sbResultat.AppendLine("Information : Au moins un document ne contient pas de caractères Unicode.") sbResultat.AppendLine("") End If sbResultat.Append("Nombre de mots indexés : " & _ Me.iNbMotsG.ToString("N", nfi) & vbCrLf) sbResultat.Append("Nombre de mots distincts indexés : " & _ Me.m_htMots.Count().ToString("N", nfi) & vbCrLf) sbResultat.Append("Nombre de phrases indexées : " & _ m_colPhrases.Count().ToString("N", nfi) & vbCrLf) sbResultat.Append("Nombre de paragraphes indexés : " & _ Me.iNbParagG.ToString("N", nfi) & vbCrLf) If Me.tsDiffTps.Milliseconds <> 0 Then _ sbResultat.Append("Temps d'indexation : " & tsDiffTps.ToString & vbCrLf) sbResultat.Append(vbCrLf) sbResultat.Append("Liste des documents indexés (" & Me.m_colDocs.Count() & ") :" & vbCrLf) 'Dim de As DictionaryEntry 'For Each de In m_colDocs ' Dim oDoc As clsDoc = DirectCast(de.Value, clsDoc) ' sbResultat.Append(oDoc.sChemin & " (" & oDoc.sCle & ")" & vbCrLf 'Next de Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs Dim sUnicode$ = "" If oDoc.bTxtUnicode Then sUnicode = ":Unicode" ' 24/05/2019 sbResultat.AppendLine(oDoc.sChemin & " (" & oDoc.sCodeDoc & sUnicode & ")") Next oDoc If m_bIndexerChapitre Then sbResultat.AppendLine(vbCrLf & "Liste des chapitres :") sbResultat.Append(m_sbChapitres) ' Identique à m_sbChapitres : 'For Each oDoc In Me.m_colDocs ' sbResultat.AppendLine(vbCrLf & oDoc.sChemin & " (" & oDoc.sCodeDoc & ") :") ' For Each chapitre As clsChapitre In oDoc.colChapitres ' sbResultat.AppendLine(chapitre.sCodeChapitre & " : " & chapitre.sChapitre) ' Next chapitre 'Next oDoc End If If Not bHtml Then CtrlResultat.Text = sbResultat.ToString If Not bListerPhrases Then GoTo Suite sbResultat.Append(vbCrLf & "Liste des phrases :") Dim i%, iMemParag%, sMemCleDoc$ Dim oPhrase As clsPhrase sMemCleDoc = "" For i = 1 To Me.iNbPhrasesG ' Parcours de toutes les phrases oPhrase = DirectCast(m_colPhrases.Item(i - 1), clsPhrase) If oPhrase.sCleDoc <> sMemCleDoc Then sbResultat.Append(vbCrLf & vbCrLf & "Document : " & _ DirectCast(Me.m_colDocs(oPhrase.sCleDoc), clsDoc).sChemin & _ " (" & sLireCodeDoc(oPhrase.sCleDoc) & ")" & vbCrLf) sbResultat.Append(vbCrLf) ElseIf oPhrase.iNumParagrapheL <> iMemParag Then sbResultat.Append(vbCrLf) End If sbResultat.Append(oPhrase.sPhrase) iMemParag = oPhrase.iNumParagrapheL sMemCleDoc = oPhrase.sCleDoc If bHtml Then Continue For If sbResultat.Length > iMaxLongChaine0 Then Exit For If i Mod iModuloAvanvementRapide = 0 Then CtrlResultat.Text = sbResultat.ToString End If Next i Suite: If bHtml Then ' On duplique ici car on va modifier le sb pour le html m_sbResultatTxt = New StringBuilder m_sbResultatTxt.Append(sbResultat) m_sbResultatHtml = sbResultat.Replace(vbLf, "<br>") Exit Sub End If ' Afficher le résultat final si ce n'est pas déjà fait If CtrlResultat.ToString() <> sbResultat.ToString And _ sbResultat.Length <= iMaxLongChaine0 Then _ CtrlResultat.Text = sbResultat.ToString If sbResultat.Length > iMaxLongChaine0 Then CtrlResultat.Text &= "..." End Sub Private Function bAjouterDocument(sCleDoc$, sCodeDoc$, _ ByRef sCheminFichier$, bTxtUnicode As Boolean, Optional colChapitres As Collection = Nothing) As Boolean ' Ajouter un document à la liste des documents indexés bAjouterDocument = False ' Stocker les chemins en relatif le cas échéant Dim sCheminAIndexer$ Dim sFichier$ = "" Dim sChemin$ = sExtraireChemin(sCheminFichier, sFichier) If sChemin.ToLower = m_sCheminDossierCourant.ToLower Then sCheminAIndexer = sFichier Else sCheminAIndexer = sCheminFichier End If Dim oDoc As clsDoc ' Vérifier si le document est déjà indexé For Each oDoc In Me.m_colDocs If oDoc.sChemin.ToLower = sCheminAIndexer.ToLower Then Return False Next oDoc oDoc = New clsDoc oDoc.sChemin = sCheminAIndexer oDoc.sCle = sCleDoc oDoc.sCodeDoc = sCodeDoc oDoc.bTxtUnicode = bTxtUnicode ' 26/01/2019 If Not IsNothing(colChapitres) Then oDoc.colChapitres = colChapitres End If 'm_colDocs.Add(oDoc, oDoc.sCle) Const sMsgModeMultiDoc$ = "Indexation des documents" 'If m_colDocs.ContainsKey(sCodeDoc) Then If bCleDocExiste(sCleDoc) Then ' Pertinent dans la version VB6, dans la version VB7 on ne peut pas le changer ' c'est dans la gestion du fichier ini que l'on vérifie l'unicité de la clé ' avec la hastable MsgBox("La clé '" & sCleDoc & "' a déjà été utilisée", _ MsgBoxStyle.Critical, sMsgModeMultiDoc) GoTo Fin End If Try 'm_colDocs.Add(oDoc.sCle, oDoc) ' Hastable Me.m_colDocs.Add(oDoc, sCleDoc) ' Collection Catch Err As Exception ' Erreur managée AfficherMsgErreur2(Err, "bAjouterDocument", _ "Impossible d'ajouter le document : " & sCodeDoc & " : " & sCheminAIndexer) End Try Return True Fin: End Function Public Function bMotExiste(sMot$, ByRef oMot As clsMot) As Boolean ' Vérifier si un mot est indexé, et retourner le mot le cas échéant Dim sCle$ If m_bIndexerAccents Then ' Les mots accentués sont distingués sCle = sMot Else ' Les mots accentués ne sont pas distingués sCle = sEnleverAccents(sMot) End If bMotExiste = Me.bCleExiste(sCle, oMot) If bMotExiste Then Exit Function ' Si on récupère un index de la version VB6, tester aussi avec les accents If m_bIndexerAccents Then Exit Function If Not bCompatVB6RechercheAussiAvecAccents Then Exit Function If String.Compare(sMot, sCle) = 0 Then Exit Function bMotExiste = Me.bCleExiste(sMot, oMot) End Function Private Function bCleExiste(sCle$, ByRef oMot As clsMot) As Boolean ' Vérifier si une clé figure déjà dans l'index, et retourner le mot le cas échéant oMot = Nothing If sCle.Length = 0 Then Return False bCleExiste = Me.m_htMots.ContainsKey(sCle) If Not bCleExiste Then Return False oMot = DirectCast(Me.m_htMots.Item(sCle), clsMot) End Function #End Region #Region "Gestion des fichiers ini" Public Sub LireListeDocumentsIndexesIni() ' Lire le fichier ini des documents indexés pour éditer les codes document If m_bModeDirect Then Exit Sub If Not bFichierExiste(m_sCheminFichierIni) Then Exit Sub ' Autre solution : CreateCaseInsensitiveHashtable Dim htCodesDoc As New Hashtable(StringComparer.InvariantCultureIgnoreCase) Me.m_colDocsIni = New Collection Dim asLignes() = sLireFichier(m_sCheminFichierIni).Split(CChar(vbLf)) For Each sLigne In asLignes ' 24/05/2019 Changement du séparateur : | pour tenir compte de C: éventuellement Dim asChamps() = sLigne.Split(CChar(sSepIni)) '"|"c) Dim iNbChamps% = asChamps.GetLength(0) If iNbChamps = 0 Then Continue For Dim sCheminDoc$ = "", sCodeDoc$ = "", bTxtUnicode = False If iNbChamps > 0 Then sCheminDoc = asChamps(0).Trim If iNbChamps > 1 Then sCodeDoc = asChamps(1).Trim If iNbChamps > 2 Then bTxtUnicode = (asChamps(2).Trim = "Unicode") 'Dim iPos = sLigne.LastIndexOf(":") 'If iPos <= 0 Then Continue For 'Dim sCheminDoc$ = "", sCodeDoc$ = "", bTxtUnicode = False 'Dim sGauche = Left(sLigne, iPos) 'Dim sDernChamp = Mid(sLigne, iPos + 2).Trim '' 26/01/2019 Ajout du champ optionnel bUnicode : pas possible avec .LastIndexOf(":") 'If sDernChamp = sTagUnicodeIni Then ' bTxtUnicode = True ' Dim iPos2 = sGauche.LastIndexOf(":") ' If iPos2 <= 0 Then Continue For ' sCheminDoc = Left(sLigne, iPos2) ' sCodeDoc = Mid(sGauche, iPos2 + 2).Trim 'Else ' sCheminDoc = sGauche ' sCodeDoc = sDernChamp 'End If ' Vérifier si le document existe LireDoc(htCodesDoc, sCheminDoc, sCodeDoc, bTxtUnicode) ' Vérifier si le code doc existe déjà If htCodesDoc.ContainsKey(sCodeDoc) Then 'MsgBox("Le code document '" & sCodeDoc & "' existe déjà !", _ ' MsgBoxStyle.Information, "Lecture des codes document") Continue For End If htCodesDoc.Add(sCodeDoc, sCodeDoc) ' La collection VB6 préserve l'ordre Dim oDoc As New clsDoc oDoc.sCle = sCodeDoc oDoc.sCodeDoc = sCodeDoc oDoc.sChemin = sCheminDoc oDoc.bTxtUnicode = bTxtUnicode ' 26/01/2019 If bTxtUnicode Then If Not m_bOptionTexteUnicode Then m_bAvertAuMoinsUnTxtUnicode = True Else If m_bOptionTexteUnicode Then m_bInfoAuMoinsUnTxtNonUnicode = True End If Me.m_colDocsIni.Add(oDoc, sCodeDoc) Next sLigne End Sub Private Sub LireDoc(htCodesDoc As Hashtable, sCheminDoc$, sCodeDoc$, bTxtUnicode As Boolean) For Each oDoc As clsDoc In Me.m_colDocs If oDoc.sChemin <> sCheminDoc Then Continue For ' Vérifier si le code doc existe déjà If htCodesDoc.ContainsKey(sCodeDoc) Then MsgBox("Le code document '" & sCodeDoc & "' existe déjà !", MsgBoxStyle.Information, "Lecture des codes document") Continue For End If htCodesDoc.Add(sCodeDoc, sCodeDoc) ' Mettre à jour le code doc If sCodeDoc <> oDoc.sCodeDoc Then m_bIndexModifie = True oDoc.sCodeDoc = sCodeDoc ' 27/01/2019 Si dans le fichier ini on a Unicode, alors reporter l'info. If bTxtUnicode AndAlso Not oDoc.bTxtUnicode Then m_bIndexModifie = True oDoc.bTxtUnicode = bTxtUnicode End If Exit Sub Next oDoc End Sub Public Sub AfficherFichierIni() ' 29/08/2010 Pas de fichier ini si un seul document If Not bFichierExiste(m_sCheminFichierIni) Then Exit Sub Shell("notepad.exe " & m_sCheminFichierIni, AppWinStyle.NormalFocus) ' Les fichiers ini ne sont pas forcément associés au bloc-notes, à éviter : 'OuvrirAppliAssociee(m_sCheminFichierIni) End Sub Private Sub EcrireListeDocumentsIndexesIni( _ Optional bAfficherIni As Boolean = False) ' Afficher la liste des documents indexés If Not bFichierAccessible(m_sCheminFichierIni, _ bPrompt:=True, bInexistOk:=True) Then Exit Sub ' 01/06/2019 Faire un .bak : VBTextFinder.ini -> VBTextFinder-ini.bak If bFichierExiste(m_sCheminFichierIni) Then Dim sDossierBak$ = sDossierParent(m_sCheminFichierIni) Dim sFichierIniBak$ = IO.Path.GetFileNameWithoutExtension(m_sCheminFichierIni) & "-ini.bak" Dim sCheminBak$ = sDossierBak & "\" & sFichierIniBak If Not bFichierAccessible(sCheminBak, bPrompt:=True, bInexistOk:=True) Then Exit Sub If Not bCopierFichier(m_sCheminFichierIni, sCheminBak) Then Exit Sub End If Dim sb As New StringBuilder Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs Dim sLigne$ = oDoc.sChemin & sSepIni & oDoc.sCodeDoc If oDoc.bTxtUnicode Then sLigne &= sSepIni & sTagUnicodeIni ' 26/01/2019 sb.Append(sLigne).Append(vbCrLf) Next oDoc For Each oDoc In Me.m_colDocsIni Dim sLigne$ = oDoc.sChemin & sSepIni & oDoc.sCodeDoc If oDoc.bTxtUnicode Then sLigne &= sSepIni & sTagUnicodeIni ' 26/01/2019 sb.Append(sLigne).Append(vbCrLf) Next oDoc If Not bEcrireFichier(m_sCheminFichierIni, sb) Then Exit Sub If bAfficherIni Then AfficherFichierIni() End Sub #End Region #Region "Algorithme de recherche" Public Sub ChercherOccurrencesMot( _ ByRef CtrlMot As ComboBox, ByRef CtrlResultat As TextBox, iNbZoomParag%, _ bAfficherInfoResultat As Boolean, bAfficherInfoDoc As Boolean, _ bAfficherNumParag As Boolean, bAfficherNumPhrase As Boolean, _ bAfficherNumOccur As Boolean, bAfficherTiret As Boolean, _ bHtml As Boolean) ' Fonction principale du moteur de recherche d'un mot dans l'index ' Lors de l'initialisation du logiciel, la zone est vide Dim sMot$ = CtrlMot.Text If sMot = "" Then Exit Sub Static bRechercheEnCours As Boolean If bRechercheEnCours Then Exit Sub bRechercheEnCours = True Dim oMot As clsMot = Nothing If Not bMotExiste(sMot, oMot) Then AfficherMessage("Mot non trouvé : " & sMot) GoTo Fin End If m_bInterrompre = False Dim sbResultat As New StringBuilder Dim alResultats As New ArrayList(oMot.aiNumPhrase) 'Dim iNbPhrasesTrouvees% = alResultats.Count Dim sExpressions$ = CtrlMot.Text Dim alExpressions As New ArrayList() If m_bIndexerAccents Then alExpressions.Add(sExpressions.ToLower) Else ' Enlever les accents et passer en minuscule alExpressions.Add(sEnleverAccents(sExpressions)) End If Dim iNbOccurrencesTot% = oMot.iNbPhrases 'CtrlResultat.SuspendLayout() Sablier() ' 01/05/2010 AfficherResultats(sExpressions, alResultats, iNbZoomParag, bAfficherInfoResultat, _ bAfficherInfoDoc, bAfficherNumParag, bAfficherNumPhrase, bAfficherNumOccur, _ iNbOccurrencesTot, bAfficherTiret, sbResultat, CtrlResultat, alExpressions, bHtml) If bAfficherInfoResultat Then _ RestaurerPositionCurseur(CtrlResultat, sMot, _ m_iNumParagSel, m_iNumPhraseSel, m_iNumCarSel, m_iLongSel, iNbZoomParag, sbResultat) 'CtrlResultat.ResumeLayout() AjouterMotDejaTrouve(sExpressions, CtrlMot) Fin: Sablier(bDesactiver:=True) ' 01/05/2010 bRechercheEnCours = False End Sub Public Sub ChercherOccurrencesMots( _ ByRef CtrlMot As ComboBox, ByRef CtrlResultat As TextBox, iNbZoomParag%, _ bAfficherInfoResultat As Boolean, bAfficherInfoDoc As Boolean, _ bAfficherNumParag As Boolean, bAfficherNumPhrase As Boolean, _ bAfficherNumOccur As Boolean, bAfficherTiret As Boolean, _ bHtml As Boolean) ' Chercher des occurrences de mots ou expressions complexes entre guillemets ' Lors de l'initialisation du logiciel, la zone est vide Dim sExpressions$ = CtrlMot.Text If sExpressions = "" Then Exit Sub Static bRechercheEnCours As Boolean If bRechercheEnCours Then Exit Sub bRechercheEnCours = True Dim alResultats As ArrayList Dim alExpressions As ArrayList Static alMemResultats As New ArrayList Static alMemExpressions As New ArrayList If sExpressions = m_sMemExpression Then alResultats = alMemResultats alExpressions = alMemExpressions GoTo AfficherResultats End If m_sMemExpression = sExpressions Sablier() ' Extraire les expressions délimitées par les guillemets Dim asExpressions() = asArgLigneCmd(sExpressions, bSupprimerEspaces:=False) alExpressions = New ArrayList() 'asExpressions) For Each sExpression As String In asExpressions If m_bIndexerAccents Then alExpressions.Add(sExpression.ToLower) Else ' Enlever les accents et passer en minuscule alExpressions.Add(sEnleverAccents(sExpression)) End If Next alMemExpressions = alExpressions Dim oPhrase As clsPhrase Dim iNumPhrase As Integer alResultats = New ArrayList ' Liste des n° de phrase validée ' Rechercher les phrases contenant les expressions demandées For Each oPhrase In m_colPhrases iNumPhrase = iNumPhrase + 1 If iNumPhrase Mod iModuloAvanvementTresLent = 0 Or iNumPhrase = Me.iNbPhrasesG Then AfficherMessage("Recherche des phrases en cours : " & _ iNumPhrase & " / " & Me.iNbPhrasesG) If m_bInterrompre Then Exit For End If ' Une phrase validée doit contenir chaque expression demandée Dim bOk As Boolean = False Dim iNbExpressions% = 0 Dim sPhrase$ = "" If m_bIndexerAccents Then sPhrase = oPhrase.sPhrase.ToLower Else sPhrase = sEnleverAccents(oPhrase.sPhrase) End If For Each sExpression As String In alExpressions If sPhrase.IndexOf(sExpression) = -1 Then Exit For iNbExpressions += 1 Next If iNbExpressions < alExpressions.Count Then Continue For alResultats.Add(iNumPhrase) Next oPhrase alMemResultats = alResultats AfficherResultats: Dim sbResultat As New StringBuilder 'Dim iNbPhrasesTrouvees% = alResultats.Count Dim iNbOccurrencesTot% = -1 ' Inconnu AfficherResultats(sExpressions, alResultats, iNbZoomParag, bAfficherInfoResultat, _ bAfficherInfoDoc, bAfficherNumParag, bAfficherNumPhrase, _ bAfficherNumOccur, iNbOccurrencesTot, bAfficherTiret, _ sbResultat, CtrlResultat, alExpressions, bHtml) If bAfficherInfoResultat Then _ RestaurerPositionCurseur(CtrlResultat, sExpressions, _ m_iNumParagSel, m_iNumPhraseSel, m_iNumCarSel, m_iLongSel, iNbZoomParag, sbResultat) AjouterMotDejaTrouve(sExpressions, CtrlMot) Sablier(bDesactiver:=True) bRechercheEnCours = False End Sub Public Sub InitNouvelleRecherche() ' On lance une nouvelle recherche : ignorer la position précédente ' (on mémorise la position précédente uniquement lorsque l'on change l'affichage en cours) m_iNumParagSel = -1 : m_iNumPhraseSel = -1 : m_iNumCarSel = -1 : m_iLongSel = -1 End Sub Private Function MarquerOccurrencesHtml(sPhraseAAfficher$, iNbCouleursHtml%) As StringBuilder If Not m_bOccurrencesEnCouleurs And Not m_bOccurrencesEnGras Then MarquerOccurrencesHtml = New StringBuilder(sPhraseAAfficher) Exit Function End If ' Mettre en gras les occurrences trouvées dans le html : <b> </b> Const sBaliseOuvCoulXX$ = "<SPAN class='OcXX'>" ' Oc pour Occurrence ' Caractère spécial ‡ : ne marche pas !?, aa non plus !? 'Const sBaliseOuvCoulXX$ = "<SPAN class='aaXX'>" Const sCodeNumOcc$ = "XX" 'Dim sBaliseOuv1$ = sBaliseOuvXX.Replace("XX", "1") Const sBaliseFermCoul$ = "</SPAN>" Const sBaliseOuvGras$ = "<b>" Const sBaliseFermGras$ = "</b>" Dim sBaliseOuvXX$ = "" Dim sBaliseFerm$ = "" If m_bOccurrencesEnCouleurs Then sBaliseOuvXX = sBaliseOuvCoulXX sBaliseFerm = sBaliseFermCoul End If If m_bOccurrencesEnGras Then sBaliseOuvXX &= sBaliseOuvGras sBaliseFerm = sBaliseFermGras & sBaliseFerm End If Dim sb As New StringBuilder Dim iNumExpression% = 0 Dim iNbExpressions% = m_alExpressions.Count For Each sExpression As String In m_alExpressions ' Inconvénient : non prise en compte de la casse : 'sPhrase = sPhrase.Replace(sExpression, "_" & sExpression & "_") Dim sBaliseOuv$ = sBaliseOuvXX If m_bOccurrencesEnCouleurs Then Dim iNumCouleurHtml% = iNumExpression Mod iNbCouleursHtml sBaliseOuv = sBaliseOuvXX.Replace(sCodeNumOcc, (iNumCouleurHtml + 1).ToString) End If ' Si la phrase contient une occurence qui est dans la balise elle-même ' alors on ne peut pas la surligner If sBaliseOuv.IndexOf(sExpression, m_styleCompare2) > -1 OrElse _ sBaliseFerm.IndexOf(sExpression, m_styleCompare2) > -1 Then iNumExpression += 1 sb.Append(sPhraseAAfficher) Continue For 'GoTo Suite End If Dim bTailleDifferente As Boolean = False Dim sPhraseAExaminer$ If m_bIndexerAccents Then sPhraseAExaminer = sPhraseAAfficher Else Dim iMemLong0% = sPhraseAAfficher.Length sPhraseAExaminer = sEnleverAccents(sPhraseAAfficher) If sPhraseAExaminer.Length <> iMemLong0 Then 'Debug.WriteLine("!") bTailleDifferente = True End If End If Dim iMemPosDebOcc% = 0 Dim iDebRechOcc% = 0 Dim iLong% = 0 Dim iMemLong% = 0 Do ' ToDo : lorsque prise en compte de la casse, alors changer l'option Dim iPosDebOcc% = sPhraseAExaminer.IndexOf(sExpression, iDebRechOcc, m_styleCompare2) If iPosDebOcc = -1 Then Exit Do Dim iLongPortionAv% = iPosDebOcc - iMemPosDebOcc - iMemLong ' 01/05/2019 Cas où l'occurrence se situe juste à la fin Dim iLongPAA% = sPhraseAAfficher.Length If iLongPortionAv <= iLongPAA Then Dim sPortionAv$ = sPhraseAAfficher.Substring(iDebRechOcc, iLongPortionAv) sb.Append(sPortionAv) End If 'Dim s3$ = sb.ToString iLong = sExpression.Length ' Bug avec les lettres collées, par ex. cœur If bTailleDifferente Then 'Dim iLongPAA% = sPhraseAAfficher.Length If iLong + iPosDebOcc > iLongPAA Then iLong = iLongPAA - iPosDebOcc If iLong <= 0 Then Exit Do ' 02/08/2010 End If End If Dim sOccurrence$ = sPhraseAAfficher.Substring(iPosDebOcc, iLong) sb.Append(sBaliseOuv & sOccurrence & sBaliseFerm) 'Dim s2$ = sb.ToString iDebRechOcc = iPosDebOcc + iLong iMemPosDebOcc = iPosDebOcc iMemLong = iLong Loop While True If iLong < 0 Then iLong = 0 ' 01/05/2019 sb.Append(sPhraseAAfficher.Substring(iMemPosDebOcc + iLong)) 'Suite: iNumExpression += 1 If iNumExpression < iNbExpressions Then sPhraseAAfficher = sb.ToString sb = New StringBuilder End If Next MarquerOccurrencesHtml = sb 'Dim s$ = MarquerOccurrencesHtml.ToString End Function Private Sub AfficherResultats(sExpressions$, alResultats As ArrayList, _ iNbZoomParag%, bAfficherInfoResultat As Boolean, _ bAfficherInfoDoc As Boolean, bAfficherNumParag As Boolean, _ bAfficherNumPhrase As Boolean, _ bAfficherNumOccur As Boolean, iNbOccurrencesTot%, _ bAfficherTiret As Boolean, _ sbResultat As StringBuilder, ByRef CtrlResultat As TextBox, _ alExpressions As ArrayList, bHtml As Boolean) Dim bTxt As Boolean = bHtml Dim bTailleLimite As Boolean = False Dim iNumPhrase% Dim sMemAffInfoDoc$ = "" Dim iNbPhrasesTrouvees% = 0 ' Une seule phrase, sinon un ou plusieurs paragraphes avant et après Dim bAfficherUnePhrase As Boolean = False If iNbZoomParag = -1 Then bAfficherUnePhrase = True Dim sResultat0$ = "" Dim iMemNumParag% = -1 ' Saut de ligne sauf la 1ère fois Dim iMemNumParagraphe% = 0 Dim iNumParagMin% = 0 Dim iNumParagMax1% Dim iNbPhrasesMot% = m_colPhrases.Count Dim iMemNumPhraseMin% = 1 Dim iMemNumPhraseG% = 0 Dim iNumPhrase1ParagMotTrouve% = 0 Dim bUnSeulDocument As Boolean 'If Me.m_colDocs.Count() = 1 Then bUnSeulDocument = True ' 29/08/2010 Afficher quand même les chapitres s'il y en a Dim bUnSeulDocumentAvecChapitres As Boolean If Me.m_colDocs.Count() = 1 Then Dim oDoc As clsDoc = DirectCast(m_colDocs.Item(1), clsDoc) If oDoc.colChapitres.Count <= 1 Then bUnSeulDocument = True Else bUnSeulDocumentAvecChapitres = True End If End If Const iTailleLimiteInteger% = iMaxLongChaine - 4 ' Laisser de la place pour afficher "..." Const iTailleLimiteAffichageTextBox% = iMaxLongChaine0 - 4 ' Afficher les phrases ou paragraphes correspondants Dim iNumOccurrence% = 0 ' Décompte de toutes les occurrences trouvées (ctrl web) Dim iNumOccurrenceAffichee% = 0 ' Décompte des occurrences affichées dans le ctrl textBox Dim iNbOccurrences% = alResultats.Count Dim sInfoOccurr$ = "" m_alExpressions = alExpressions Dim sEnteteHtml$ = "<html><body>" Dim iNumOcc% = 0 If m_bOccurrencesEnCouleurs Then Dim asCouleursHtml$() = m_sCouleursHtml.Split(";"c) For Each sCouleur As String In asCouleursHtml If String.IsNullOrEmpty(sCouleur) Then Continue For iNumOcc += 1 ' Oc pour Occurrence sEnteteHtml &= vbCrLf & "<STYLE type='text/css'>SPAN.Oc" & iNumOcc & _ " { BACKGROUND-COLOR: " & sCouleur & " }</STYLE>" Next End If Dim iNbCouleursHtml% = iNumOcc 'sEnteteHtml &= vbCrLf & "<STYLE type='text/css'>SPAN.Oc1 { BACKGROUND-COLOR: yellow }</STYLE>" 'sEnteteHtml &= vbCrLf & "<STYLE type='text/css'>SPAN.Oc2 { BACKGROUND-COLOR: green }</STYLE>" 'sEnteteHtml &= vbCrLf & "<STYLE type='text/css'>SPAN.Oc3 { BACKGROUND-COLOR: blue }</STYLE>" ' Pas obligatoire (mais il faudra préciser l'encodage au moment d'écrire le fichier) : 'If m_bTexteUnicode Then sEnteteHtml = _ ' "<html><meta http-equiv='content-type' content='text/html; charset=utf-8' /><body>" Const sPiedHtml$ = "</body></html>" Dim sbResultatHtml As StringBuilder = Nothing Dim sbResultatTxt As StringBuilder = Nothing If bHtml Then sbResultatHtml = New StringBuilder(sEnteteHtml & vbCrLf) If bTxt Then sbResultatTxt = New StringBuilder 'Const sDebLigneHtml$ = "<li>" 'Const sFinLigneHtml$ = "</li>" Const sSautLigneHtml$ = "<br>" & vbCrLf 'Const sDebParagHtml$ = "<p>" 'Const sFinParagHtml$ = "</p>" For Each iNumPhrase In alResultats iNumOccurrence += 1 If sbResultat.Length <= iTailleLimiteAffichageTextBox Then _ iNumOccurrenceAffichee += 1 If bAfficherNumOccur Then sInfoOccurr = "(occ.n°" & iNumOccurrence & ") " ' 01/05/2010 Inutile 'If iNumOccurrence Mod iModuloAvanvementLent = 0 Or iNumOccurrence = iNbOccurrences Then ' AfficherMessage("Affichage des occurrences en cours : " & _ ' iNumOccurrence & " / " & iNbOccurrences) ' If m_bInterrompre Then Exit For 'End If Dim oPhrase As clsPhrase = DirectCast(m_colPhrases.Item(iNumPhrase - 1), clsPhrase) ' 25/04/2010 Bug depuis la version V1.12 du 25/10/2009 ' Un mot est présent plusieurs fois dans la même phrase If iNumPhrase = iMemNumPhraseG Then GoTo PhraseSuivante iMemNumPhraseG = iNumPhrase 'Dim iNumParagraphe% = oPhrase.iNumParagrapheL ' Numéro de parag. local aux documents Dim iNumParagraphe% = oPhrase.iNumParagrapheG ' Numéro de parag. global aux documents ' Si la phrase suivante est dans le même §, alors elle a déjà été affichée ' (si on affiche que les phrases, alors iMemNumParagraphe reste à 0) If iNumParagraphe = iMemNumParagraphe Then GoTo PhraseSuivante Dim sAffInfoDoc$ = "" Dim sAffInfoDocHtml$ = "" Dim sInfos$ = "" Dim sInfosHtml$ = "" Dim sCleDoc$ = oPhrase.sCleDoc Dim iDecParagG2L% = 0 Dim iDecPhraseG2L% = 0 If bAfficherInfoResultat Then If bAfficherInfoDoc Then If bUnSeulDocument Then ' S'il n'y a qu'un seul document, inutile de le rappeler sAffInfoDoc = "" sAffInfoDocHtml = "" Else ' Trouver le document pour connaitre son CodeDoc edité Dim oDoc As clsDoc oDoc = DirectCast(m_colDocs.Item(oPhrase.sCleDoc), clsDoc) Dim sCodeDoc$ = oDoc.sCodeDoc Dim sChapitre$ = "" If oPhrase.sCodeChapitre.Length > 0 Then sCodeDoc &= ":" & oPhrase.sCodeChapitre Dim sCleChap$ = oPhrase.sCleDoc & ":" & oPhrase.sCodeChapitre Dim chapitre As clsChapitre = DirectCast( _ oDoc.colChapitres(sCleChap), clsChapitre) sChapitre = chapitre.sChapitre & " : " End If ' Note : le nom du document n'a pas encore été détecté ' ce n'est pas forcément évident, car cela peut être la 1ère phrase ' ou bien le nom du fichier (ou pour les documents word, une propriété) ' conclusion : le chemin est le plus simple pour le moment Dim s$ = oDoc.sChemin & " (" & sCodeDoc & ") : " & sChapitre If bUnSeulDocumentAvecChapitres Then s = sChapitre sAffInfoDoc = vbCrLf & s & vbCrLf 'sAffInfoDocHtml = vbCrLf & sDebParagHtml & s & sFinParagHtml & vbCrLf sAffInfoDocHtml = sSautLigneHtml & s & sSautLigneHtml If sAffInfoDoc = sMemAffInfoDoc Then ' S'il n'a pas changé depuis le précédent sAffInfoDoc = "" sAffInfoDocHtml = "" Else sMemAffInfoDoc = sAffInfoDoc End If End If End If If m_bNumerotationGlobale Then ' 11/10/2009 Afficher tjrs le n° de phrase global pour être cohérent ' (le n° de § est global aussi) Dim s$ = "" If bAfficherNumParag Then _ s = sIndicParag & iNumParagraphe & " " '" Ph. n°" & oPhrase.iNumPhraseG & " " If bAfficherNumPhrase Then s &= sIndicPhrase & oPhrase.iNumPhraseG & " " sInfos = sAffInfoDoc & s sInfosHtml = sAffInfoDocHtml & s Else iDecParagG2L = oPhrase.iNumParagrapheG - oPhrase.iNumParagrapheL iDecPhraseG2L = oPhrase.iNumPhraseG - oPhrase.iNumPhraseL Dim s$ = "" If bAfficherNumParag Then _ s = sIndicParag & iNumParagraphe - iDecParagG2L & " " '" Ph. n°" & oPhrase.iNumPhraseL & " " If bAfficherNumPhrase Then s &= sIndicPhrase & oPhrase.iNumPhraseL & " " sInfos = sAffInfoDoc & s sInfosHtml = sAffInfoDocHtml & s End If If bAfficherNumOccur Then sInfos &= sInfoOccurr : sInfosHtml &= sInfoOccurr End If If bAfficherUnePhrase Then Dim sTiret$ = "" If bAfficherTiret Then sTiret = "- " ' 29/05/2015 Optionnel Dim s$ = sInfos & sTiret & oPhrase.sPhrase & vbCrLf sbResultat.Append(s) If bTxt Then sbResultatTxt.Append(s) If bHtml Then sbResultatHtml.Append(sInfosHtml & sTiret).Append( _ MarquerOccurrencesHtml(oPhrase.sPhrase, iNbCouleursHtml)).Append(sSautLigneHtml) GoTo PhraseSuivante End If If iNumParagraphe = iNumParagMax1 Then GoTo PhraseSuivante ' Examiner l'occurrence suivante Dim iNumParagMax2% iNumParagMax2 = -1 Dim iNumPhraseMot% = iNumPhrase Dim iNumOccurrence0% = iNumOccurrence While iNumOccurrence0 < iNbOccurrences ' (n° de phrase) Global de l'occurrence suivante (+1) : GP1 : GlobPlus1 Dim iNumPhraseGP1 = CInt(alResultats(iNumOccurrence0)) Dim iNumParagGP1% = iLireNumParagGPhrase(iNumPhraseGP1) If iNumParagGP1 = iNumParagraphe Then ' L'occurrence suivante est dans le même § : voir l'occurrence suivante iNumOccurrence0 += 1 Continue While End If ' Vérifier si l'occ. suiv. est tjrs dans le même doc. Dim sCleDocPhraseGP1$ = Me.sLireCleDocPhrase(iNumPhraseGP1) If sCleDocPhraseGP1 = sCleDoc Then If iNumParagGP1 > iNumParagraphe + 2 * iNbZoomParag Then 'iNumParagMax2 = 0 ' Déjà traité Else iNumParagMax2 = iNumParagraphe + (iNumParagGP1 - iNumParagraphe) \ 2 End If End If Exit While End While ' Rechercher le n° de phrase du début du parag contenant le mot trouvé ' Algorithme : trouver la première phrase appartenant au parag précédent Dim iNumPhraseG% = iNumPhrase iNumPhrase1ParagMotTrouve = iNumPhraseG ' Initialisation par défaut Dim j% For j = iNumPhraseG - 1 To 1 Step -1 If bInterruption() Then GoTo FinRecherche ' ToDo : Dans cette boucle, on caste 3 fois la phrase : à optimiser If Me.sLireCleDocPhrase(j) <> sCleDoc Then Exit For Dim iNumParag_Phr_j% = iLireNumParagGPhrase(j) If iNumParag_Phr_j = iNumParagraphe Then ' La phrase précédente appartient au même paragraphe ' elle doit donc être inclue dans le paragraphe courant iNumPhrase1ParagMotTrouve = j Else ' La phrase précédente appartient au paragraphe précédent ' l'affichage du paragraphe commence donc à la phrase suivante iNumPhrase1ParagMotTrouve = j + 1 : Exit For End If Next j ' Puis noter toutes les phrases du paragraphe +- l'écart demandé Dim iNbParagAv%, iNbParagAp% iNbParagAv = iNbZoomParag : iNbParagAp = iNbZoomParag ' Rechercher les n° de § précédants Dim iMin% = 1 Dim iMemNumPhrasePreced% = iNumPhrase1ParagMotTrouve ' Cas où plusieurs § successifs contiennent le mot : un seul affichage If iMemNumPhrasePreced < iMemNumPhraseMin Then iMemNumPhrasePreced = iMemNumPhraseMin iMin = iMemNumPhraseMin End If Dim iNumPhraseDebRech% = iMemNumPhrasePreced For j = iNumPhrase1ParagMotTrouve To iMin Step -1 If bInterruption() Then GoTo FinRecherche If Me.sLireCleDocPhrase(j) <> sCleDoc Then Exit For Dim iNumParag_Phr_j% = iLireNumParagGPhrase(j) ' Noter le n° global de la phrase en cours 'If j = iNumPhrase1ParagMotTrouve Then iMemNumPhraseG = oPhrase.iNumPhraseG ' Ne pas afficher plusieurs fois le même paragraphe If j < iMemNumPhraseMin Then _ iNumPhraseDebRech = iMemNumPhrasePreced : Exit For If iNumParag_Phr_j < iNumParagraphe - iNbParagAv Then _ iNumPhraseDebRech = iMemNumPhrasePreced : Exit For iMemNumPhrasePreced = j : iNumPhraseDebRech = j Next j ' Rechercher les n° de § suivants iMemNumPhrasePreced = iNumPhrase1ParagMotTrouve Dim iNumPhraseFinRech% = iMemNumPhrasePreced For j = iNumPhrase1ParagMotTrouve To Me.iNbPhrasesG If bInterruption() Then GoTo FinRecherche Dim iNumParag_Phr_j% = iLireNumParagGPhrase(j) If iNumParag_Phr_j > iNumParagraphe Then iMemNumPhraseMin = j If iNumParag_Phr_j > iNumParagraphe + iNbParagAp Then _ iNumPhraseFinRech = iMemNumPhrasePreced : Exit For If iNumParagMax2 > -1 And iNumParag_Phr_j > iNumParagMax2 Then iNumPhraseFinRech = iMemNumPhrasePreced : Exit For End If ' Ne pas afficher 2x le dernier § If j = Me.iNbPhrasesG Then iNumParagMax1 = oPhrase.iNumParagrapheL iMemNumPhrasePreced = j : iNumPhraseFinRech = j Next j ' Afficher les § précédents et suivants demandés For j = iNumPhraseDebRech To iNumPhraseFinRech If bInterruption() Then GoTo FinRecherche oPhrase = DirectCast(m_colPhrases.Item(j - 1), clsPhrase) Dim iNumParag_Phr_j% = iLireNumParagGPhrase(j) Dim sIndicParagFinal$ = "" If iNumParag_Phr_j < iNumParagraphe Then sIndicParagFinal = "< " ElseIf iNumParag_Phr_j > iNumParagraphe Then sIndicParagFinal = "> " ElseIf bAfficherTiret OrElse iNbZoomParag > 0 Then ' 29/05/2015 Optionnel sIndicParagFinal = "- " End If If (j = iNumPhraseDebRech Or _ iNumParag_Phr_j > iMemNumParag) And iMemNumParag > -1 Then sbResultat.Append(vbCrLf) ' Nouv. Parag If bTxt Then sbResultatTxt.Append(vbCrLf) If bHtml Then sbResultatHtml.Append(sSautLigneHtml) End If If j = iNumPhraseDebRech Or iNumParag_Phr_j > iMemNumParag Then If bAfficherInfoResultat Then Dim s$ = "" If bAfficherNumParag Then _ s = sIndicParag & iNumParag_Phr_j - iDecParagG2L & " " '" Ph. n°" & j - iDecPhraseG2L & " " If bAfficherNumPhrase Then s &= sIndicPhrase & j - iDecPhraseG2L & " " sbResultat.Append(sAffInfoDoc & s) If bTxt Then sbResultatTxt.Append(sAffInfoDoc & s) If bAfficherNumOccur Then sbResultat.Append(sInfoOccurr) If bAfficherNumOccur And bTxt Then sbResultatTxt.Append(sInfoOccurr) If bHtml Then sbResultatHtml.Append(sAffInfoDocHtml & s) If bAfficherNumOccur And bHtml Then sbResultatHtml.Append(sInfoOccurr) End If sbResultat.Append(sIndicParagFinal) If bTxt Then sbResultatTxt.Append(sIndicParagFinal) If bHtml Then sbResultatHtml.Append(sIndicParagFinal) End If If bDebug Then sResultat0 &= oPhrase.sPhrase sbResultat.Append(oPhrase.sPhrase) If bTxt Then sbResultatTxt.Append(oPhrase.sPhrase) If bHtml Then sbResultatHtml.Append(MarquerOccurrencesHtml(oPhrase.sPhrase, iNbCouleursHtml)) sAffInfoDoc = "" ' N'afficher qu'une seule fois le chemin sAffInfoDocHtml = "" If bDebug Then sResultat0 = "" iMemNumParag = iNumParag_Phr_j Next j iMemNumParagraphe = iNumParagraphe PhraseSuivante: 'If sbResultat.Length > iTailleLimite Then bTailleLimite = True : Exit For If sbResultat.Length > iTailleLimiteInteger Then Exit For Next If bHtml Then sbResultatHtml.Append(sPiedHtml) m_sbResultatHtml = sbResultatHtml End If If bTxt Then m_sbResultatTxt = sbResultatTxt AfficherMessage("Affichage des résultats...") Dim iLen1% = sbResultat.Length If iLen1 > iTailleLimiteAffichageTextBox Then bTailleLimite = True Dim sbResultat0 As New StringBuilder sbResultat0.Length = 0 'sbResultat0.Append(sbResultat.ToString.Substring(0, iTailleLimite)) sbResultat0.Append(sbResultat.ToString.Substring(0, iTailleLimiteAffichageTextBox)) sbResultat0.Append("...") 'If CtrlResultat.Text <> sbResultat0.ToString Then If String.Compare(CtrlResultat.Text, sbResultat0.ToString) <> 0 Then ' C'est cette ligne qui prend du temps CtrlResultat.Text = sbResultat0.ToString End If Else If m_bInterrompre Then sbResultat.Append("...") 'If CtrlResultat.Text <> sbResultat.ToString Then If String.Compare(CtrlResultat.Text, sbResultat.ToString) <> 0 Then ' C'est cette ligne qui prend du temps 'CtrlResultat.Text = sbResultat.ToString ' 01/05/2010 On va le faire en deux temps Const iPrevisu% = 5000 If sbResultat.Length > iPrevisu Then Dim sbResultat0 As New StringBuilder sbResultat0.Append(sbResultat.ToString.Substring(0, iPrevisu)) sbResultat0.Append("...") CtrlResultat.Text = sbResultat0.ToString Application.DoEvents() ' Parfois le sablier n'a pas été bien activé ' (car le ctrl text avait encore le focus ?) Sablier() End If CtrlResultat.SuspendLayout() CtrlResultat.Text = sbResultat.ToString CtrlResultat.ResumeLayout() End If End If FinRecherche: iNbPhrasesTrouvees = iNumOccurrenceAffichee 'iNumOccurrence If m_bInterrompre Or bTailleLimite Then If iNbOccurrencesTot = -1 Then ' Cas des expressions : on ne connait pas le nombre total d'occurences AfficherMessage(sExpressions & " : Nombre d'occurrences affichées : " & _ iNbPhrasesTrouvees) Else ' Cas des mots : on connait le nbre total via l'index AfficherMessage(sExpressions & " : Nombre d'occurrences affichées : " & _ iNbPhrasesTrouvees & " / " & iNbOccurrencesTot & " trouvées") End If Else ' Si on connait le total, alors il est plus fiable If iNbOccurrencesTot <> -1 Then iNbPhrasesTrouvees = iNbOccurrencesTot AfficherMessage(sExpressions & " : Nombre d'occurrences trouvées : " & _ iNbPhrasesTrouvees) End If End Sub Public Sub NoterPositionCurseur(CtrlResultat As Windows.Forms.TextBox, _ bAfficherInfoResultat As Boolean, bAfficherNumParag As Boolean, _ bAfficherNumPhrase As Boolean) 'Debug.WriteLine(Now & " : Memo pos. curseur") m_iNumParagSel = -1 m_iNumPhraseSel = -1 m_iNumCarSel = -1 m_iLongSel = -1 ' On a besoin de la numérotation globale pour que cela marche : If Not m_bNumerotationGlobale Then Exit Sub If Not bAfficherInfoResultat Then Exit Sub ' On a besoin des 2 repères § et Ph. pour que cela marche : If Not bAfficherNumParag Then Exit Sub If Not bAfficherNumPhrase Then Exit Sub NoterPositionCurseur2(CtrlResultat, _ m_iNumParagSel, m_iNumPhraseSel, m_iNumCarSel, m_iLongSel) End Sub Private Sub NoterPositionCurseur2(CtrlResultat As Windows.Forms.TextBox, _ ByRef iNumParagSel%, ByRef iNumPhraseSel%, ByRef iNumCarSel%, ByRef iLongSel%) 'iNumCarSel : n° du car. sel. dans la phrase en cours 'iNumPhraseSel : n° de la phrase sel. global 'iNumParagSel : n° du parag. sel. global iNumParagSel = -1 iNumPhraseSel = -1 iNumCarSel = -1 iLongSel = -1 Const sReperePhrase$ = " " & sIndicPhrase '" Ph. n°" ' Recherche du parag. courant : contenant le mot actuellement sélectionné Dim sCtrlResultat$ = CtrlResultat.Text.ToString Dim iPosDebParagSel% = -1 Dim iNumCarDebSelCtrl% ' Noter la sélection en cours dans le ctrl pour tenter de la restituer iNumCarDebSelCtrl = CtrlResultat.SelectionStart iLongSel = CtrlResultat.SelectionLength If iNumCarDebSelCtrl >= 0 And iNumCarDebSelCtrl < sCtrlResultat.Length Then _ iPosDebParagSel = sCtrlResultat.LastIndexOf(sCarParag, iNumCarDebSelCtrl) If iPosDebParagSel > -1 Then Dim iLongMax% = 40 If sCtrlResultat.Length < iLongMax + iPosDebParagSel Then _ iLongMax = sCtrlResultat.Length - iPosDebParagSel If iLongMax < 0 Then iLongMax = 0 Dim sLigne$ = sCtrlResultat.Substring(iPosDebParagSel, iLongMax) Dim iLen% = sLigne.Length Dim iCarNumero% = sLigne.IndexOf("°") If iCarNumero = -1 Then GoTo Fin Dim iCarEspace% = sLigne.IndexOf(" ", iCarNumero) If iCarEspace = -1 Then GoTo Fin Dim sNumParagSel$ = "" If iCarNumero + 1 >= 0 And iCarEspace - iCarNumero - 1 <= iLen Then sNumParagSel = sLigne.Substring(iCarNumero + 1, iCarEspace - iCarNumero - 1) 'iNumParagSel = CInt(sNumParagSel) iNumParagSel = iConv(sNumParagSel) End If If iNumParagSel = -1 Then GoTo Fin Dim iCarPhrase% = sLigne.IndexOf(sReperePhrase, iCarEspace) If iCarPhrase = -1 Then GoTo Fin Dim iCarEspace2% = 0 'iDebLigne : nbr de car. en partant de la gauche du ctrl, de la pos. du curseur ' même paragraphe : utile lors du passage de Phrase vers Parag. Dim iDebLigne% = iCarEspace + 3 Dim sNumPhrase$ = "" If iCarPhrase > -1 Then iCarEspace2 = sLigne.IndexOf(" ", iCarPhrase + sReperePhrase.Length) If iCarEspace2 = -1 Then GoTo Fin iDebLigne = iCarEspace2 + 3 Dim iPosNum% = iCarPhrase + sReperePhrase.Length If iPosNum >= 0 And iCarEspace2 - iPosNum <= iLen Then sNumPhrase = sLigne.Substring(iPosNum, iCarEspace2 - iPosNum) 'iNumPhraseSel = CInt(sNumPhrase) iNumPhraseSel = iConv(sNumPhrase) End If End If iNumCarSel = iNumCarDebSelCtrl - iPosDebParagSel - iDebLigne If iNumPhraseSel = -1 Then GoTo Fin iDebLigne = iCarEspace2 + 3 Const bDebugPos As Boolean = False If bDebugPos Then _ MsgBox("DebLigne=" & iDebLigne & ", Car=" & iNumCarSel & _ ", Ph:" & iNumPhraseSel & ", §:" & iNumParagSel) ' Si on passe de § à phrase, décaller le curseur au début de la phrase effective Dim iLen2% = 0 Do Dim sPhrase$ = sLirePhrase(iNumPhraseSel) iLen2 = sLirePhrase(iNumPhraseSel).Length If iNumCarSel < iLen2 Then Exit Do iNumCarSel -= iLen2 If iNumPhraseSel >= Me.iNbPhrasesG Then Exit Do iNumPhraseSel += 1 If bDebugPos Then _ MsgBox("DebLigne=" & iDebLigne & ", Car=" & iNumCarSel & _ ", Ph:" & iNumPhraseSel & ", §:" & iNumParagSel) Loop While True End If Fin: 'Debug.WriteLine(Now & " : Pos. curseur : §" & iNumParagSel & ", Ph." & _ ' iNumPhraseSel & ", Car." & iNumCarSel & ", Long." & iLongSel) End Sub Private Sub RestaurerPositionCurseur(CtrlResultat As Windows.Forms.TextBox, sMot$, _ iNumParagSel%, iNumPhraseSel%, iNumCarSel%, iLongSel%, _ iNbZoomParag%, sbResultat As StringBuilder) Static sMemMot$ = "" If Not m_bNumerotationGlobale OrElse sMemMot <> sMot Then CtrlResultat.Select() CtrlResultat.SelectionStart = 0 CtrlResultat.SelectionLength = 0 CtrlResultat.ScrollToCaret() ElseIf iNumParagSel > -1 Then ' Analyse du parag courant Dim iCumulLongPhrPrecedParag% = 0 'iCumulLongPhrPrecedParag : Cumul des longueurs des phrases précédentes du § ' 24/10/2009 And iNumPhraseSel > -1 If sMemMot = sMot And iNbZoomParag > -1 And iNumPhraseSel > -1 Then Dim sCleDoc$ = Me.sLireCleDocPhrase(iNumPhraseSel) For j = iNumPhraseSel - 1 To 1 Step -1 ' ToDo : Dans cette boucle, on caste 3 fois la phrase : à optimiser If Me.sLireCleDocPhrase(j) <> sCleDoc Then Exit For Dim iNumParag_Phr_j% = -1 iNumParag_Phr_j = iLireNumParagGPhrase(j) If iNumParag_Phr_j < iNumParagSel Then Exit For ' La phrase précédente appartient au même paragraphe ' elle doit donc être inclue dans le paragraphe courant If iNumParag_Phr_j = iNumParagSel And j < iNumPhraseSel Then 'And iMemZoomParag = -1 'si on passe de Phrase à § ' Décaller la sélection de la longueur de la phrase précéd. ' Si même §, même mot, si on est en § iCumulLongPhrPrecedParag += sLirePhrase(j).Length End If Next j End If CtrlResultat.SuspendLayout() ' Eviter le scintillement pdt le focus CtrlResultat.Select() ' Focus ' Déselectionner après Select CtrlResultat.SelectionStart = 0 CtrlResultat.SelectionLength = 0 CtrlResultat.ResumeLayout() ' Sélection du paragraphe suivant pour rendre visible le précédent Dim sRepere$ = sIndicParag & (iNumParagSel + 1) & " " Dim sResultat$ = sbResultat.ToString Dim iPos% = sResultat.IndexOf(sRepere) If iPos = -1 Then ' 25/10/2009 Le prochain § n'a pas été trouvé (passage en mode phrase seul) : ' dans ce cas il faut d'abord rechercher le § en cours sRepere = sIndicParag & iNumParagSel & " " iPos = sResultat.IndexOf(sRepere) If iPos > -1 Then ' Puis le prochain saut de ligne Dim iPos0% = sResultat.IndexOf(vbLf, iPos) If iPos0 > -1 Then iPos = iPos0 End If End If If iPos > -1 Then CtrlResultat.SelectionStart = iPos CtrlResultat.SelectionLength = 0 CtrlResultat.ScrollToCaret() End If ' Sélection du paragraphe courant maintenant sRepere = sIndicParag & iNumParagSel & " " & sIndicPhrase & iNumPhraseSel & " " iPos = sResultat.IndexOf(sRepere) If iPos > -1 Then CtrlResultat.SelectionStart = iPos CtrlResultat.SelectionLength = 0 CtrlResultat.ScrollToCaret() ' Si possible retrouver la position du curseur dans le parag. sel. Dim iSelStart% = iPos + sRepere.Length + 2 + _ iCumulLongPhrPrecedParag + iNumCarSel If iSelStart > -1 And iNumCarSel > -1 Then ' C'est possible CtrlResultat.SelectionStart = iSelStart CtrlResultat.SelectionLength = iLongSel Else ' Echec : selectionner seulement le repère CtrlResultat.SelectionLength = sRepere.Length - 1 End If Else ' Si la phrase exacte n'a pu etre retrouvée et que l'on est en mode phrase ' alors on perd le mot sélectionné If iNbZoomParag = -1 Then iLongSel = 0 : iNumCarSel = -1 ' Si les phrases sont regroupées en parag. ne pas tenter de rech. la phr. sRepere = sIndicParag & iNumParagSel & " " ' Ph. n°" & iNumPhraseSel & " " iPos = sResultat.IndexOf(sRepere) If iPos > -1 Then CtrlResultat.SelectionStart = iPos CtrlResultat.SelectionLength = 0 CtrlResultat.ScrollToCaret() Dim iSelStart% = iPos + sRepere.Length + 2 + _ iCumulLongPhrPrecedParag + iNumCarSel ' Retrouver le début de la première phrase Dim sRepere2$ = " " & sIndicPhrase '" Ph. n°" Dim iPos2% = sResultat.IndexOf(sRepere2, iPos) If iPos2 > 1 Then iPos2 = sResultat.IndexOf(" ", iPos2 + sRepere2.Length) iSelStart = iPos2 + 3 + iCumulLongPhrPrecedParag + iNumCarSel End If ' Si possible retrouver la position du curseur dans le parag. sel. If iSelStart > -1 And iNumCarSel > -1 Then ' C'est possible CtrlResultat.SelectionStart = iSelStart CtrlResultat.SelectionLength = iLongSel Else ' Echec : selectionner seulement le repère CtrlResultat.SelectionLength = sRepere.Length - 1 End If End If End If End If sMemMot = sMot End Sub Private Sub AjouterMotDejaTrouve(sExpressions$, ByRef CtrlMot As Windows.Forms.ComboBox) ' Ajouter le mot à la combobox des mots déjà recherchés, ' si ce n'est pas déjà fait Dim sExpressionsMin$ = sExpressions.ToLower Dim bDejaRecherche As Boolean For j = 0 To CtrlMot.Items.Count - 1 If DirectCast(CtrlMot.Items(j), String).ToLower = sExpressionsMin Then _ bDejaRecherche = True : Exit For Next j If Not bDejaRecherche Then CtrlMot.Items.Add(sExpressions) End Sub 'Private Function iLireNumParagLPhrase%(iNumPhraseG%) ' ' Lire le n° de paragraphe local en fonction du n° de phrase global ' Dim oPhrase As clsPhrase ' oPhrase = DirectCast(m_colPhrases.Item(iNumPhraseG - 1), clsPhrase) ' iLireNumParagLPhrase = oPhrase.iNumParagrapheL 'End Function Private Function iLireNumParagGPhrase%(iNumPhraseG%) ' Lire le n° de paragraphe global en fonction du n° de phrase global If iNumPhraseG < 1 OrElse iNumPhraseG > Me.iNbPhrasesG Then iLireNumParagGPhrase = -1 : Exit Function End If Dim oPhrase As clsPhrase oPhrase = DirectCast(m_colPhrases.Item(iNumPhraseG - 1), clsPhrase) iLireNumParagGPhrase = oPhrase.iNumParagrapheG End Function Private Function sLirePhrase$(iNumPhraseG%) ' Lire la phrase en fonction du n° de phrase global If iNumPhraseG < 1 OrElse iNumPhraseG > Me.iNbPhrasesG Then sLirePhrase = "" : Exit Function End If Dim oPhrase As clsPhrase oPhrase = DirectCast(m_colPhrases.Item(iNumPhraseG - 1), clsPhrase) sLirePhrase = oPhrase.sPhrase End Function Public Function bHyperTexte(ByRef sMotSel$, ByRef sMotSelFin$) As Boolean ' Traitement du mode hypertexte Dim iLongMot%, iDeb%, iFin% Dim sCar1$, sCar2$ If sMotSel = "" Then Return False ' Extraction d'un mot bien délimité ' Vérifier s'il y a une virgule à la fin If bSeparateurMots(Right(sMotSel, 1)) Then _ sMotSel = Left(sMotSel, Len(sMotSel) - 1) ' Tester aussi le cas du . If bSeparateurPhrases(Right(sMotSel, 1)) Then _ sMotSel = Left(sMotSel, Len(sMotSel) - 1) iLongMot = Len(sMotSel) For iDeb = 1 To iLongMot - 1 ' Vérifier s'il y a : l' sCar1 = Mid(sMotSel, iDeb, 1) sCar2 = Mid(sMotSel, iDeb + 1, 1) If Not bSeparateurMots(sCar1) And (Not bSeparateurMots(sCar2) Or iLongMot < 4) Then Exit For Next iDeb If iDeb = iLongMot Then sMotSelFin = Right(sMotSel, 1) : Return False ' Vérifier les mots composés : c'est-à-dire : est For iFin = iDeb + 1 To iLongMot sCar1 = Mid(sMotSel, iFin, 1) If bSeparateurMots(sCar1) Then Exit For Next iFin sMotSelFin = Mid(sMotSel, iDeb, iFin - iDeb) ' Inutile de lancer une recherche automatique pour des mots de moins de 3 lettres If Len(Trim(sMotSelFin)) < 3 Then Return False Return True End Function Private Function bContientSeparateurPhrases(sMot$) As Boolean ' Indiquer si le mot contient un séparateur de phrases Dim i%, iLen% iLen = Len(sMot) For i = 1 To iLen If bSeparateurPhrases(Mid(sMot, i, 1)) Then Return True Next i ' Ce mot n'en contient pas Return False End Function Private Function bSeparateurPhrases(sCar$) As Boolean ' Indiquer si le caractère est un séparateur de phrases If InStr(Me.m_sListeSeparateursPhrase, sCar) > 0 Then Return True Return False End Function Public Function bSeparateurMots(sCar$) As Boolean ' Indiquer si le caractère est un séparateur de mots If InStr(m_sListeSeparateursMot, sCar) > 0 Then Return True Return False End Function #End Region #Region "Sérialisation de l'index" Private Function bValiderSauvegardeTmp() As Boolean ' Conserver la sauvegarde précédente (si elle existe) : ' renommer le fichier VBTxtFnd.idx en VBTxtFnd.bak ' Valider la sauvergarde temporaire (si elle n'existe pas, la créer) : ' renommer le fichier VBTxtFnd.tmp en VBTxtFnd.idx ' Si le fichier .tmp n'existe pas, on sauvegarde l'index If Not bFichierExiste(m_sCheminVBTxtFndTmp) Then _ If Not bSauvegarderIndex(m_sCheminVBTxtFndTmp) Then Return False ' Renommer le fichier VBTxtFnd.idx en VBTxtFnd.bak If Not bRenommerFichier(m_sCheminVBTxtFndIdx, m_sCheminVBTxtFndBak) Then Return False ' Renommer le fichier VBTxtFnd.tmp en VBTxtFnd.idx If Not bRenommerFichier(m_sCheminVBTxtFndTmp, m_sCheminVBTxtFndIdx) Then Return False Return True End Function Private Function bSauvegarderIndex(sCheminFichierIndex$) As Boolean ' Sauvegarder l'index dans le fichier VBTextFinder.idx If Not bFichierAccessible(sCheminFichierIndex, _ bPrompt:=True, bInexistOk:=True) Then Return False bSauvegarderIndex = False Sablier() AfficherMessage("Sauvegarde de l'index en cours...") LireListeDocumentsIndexesIni() Dim iEncodage% = iCodePageWindowsLatin1252 If m_bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 Dim fs As IO.FileStream = Nothing Try fs = New IO.FileStream(sCheminFichierIndex, IO.FileMode.Create, IO.FileAccess.Write) Using bw As New IO.BinaryWriter(fs, Encoding.GetEncoding(iEncodage)) Dim rVersion! = rVersionFichierVBTxtFndIdx10 If m_bIndexerChapitre Then rVersion = rVersionFichierVBTxtFndIdx bw.Write(rVersion) ' Sauvegarder le nombre de documents indexés Dim iNbDocs%, iNbMots% iNbDocs = Me.m_colDocs.Count() iNbMots = Me.m_htMots.Count() bw.Write(iNbDocs) bw.Write(iNbMots) ' Nbr de mots distincts indexés bw.Write(Me.iNbPhrasesG) ' Réserver de la place pour compléter les statistiques générales ' dans une version future (afin de conserver la compatibilité du fichier index) bw.Write(Me.iNbParagG) ' Nombre de paragraphes indexés en tout bw.Write(Me.iNbMotsG) ' Nombre de mots indexés en tout ' Non : Nombre de caractères y compris les séparateurs de mot : à faire 'bw.Write(CInt(0)) 'iNbCarDontSeparIndexes ' 22/05/2010 bUnicode ou pas Dim iOptionsEncodage% = 0 If m_bOptionTexteUnicode Then iOptionsEncodage += iMasqueOptionUnicode If m_bIndexerAccents Then iOptionsEncodage += iMasqueOptionAccent bw.Write(iOptionsEncodage) ' Sauvegarder la liste des documents indexés 'Dim de As DictionaryEntry 'For Each de In m_colDocs ' Dim oDoc As clsDoc = DirectCast(de.Value, clsDoc) 'Next de Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs bEcrireChaine(bw, oDoc.sCle) bEcrireChaine(bw, oDoc.sCodeDoc) 'Debug.WriteLine(oDoc.sCle & ", " & oDoc.sCodeDoc) bEcrireChaine(bw, oDoc.sChemin) ' Réserver de la place pour compléter les statistiques par document Dim iVal% = 0 bw.Write(iVal) 'oDoc.iNbMotsIndexes bw.Write(iVal) 'oDoc.iNbPhrasesIndexees bw.Write(iVal) 'oDoc.iNbParagIndexes bw.Write(iVal) 'oDoc.iNbCarIndexes ' Nombre de caractères dont les séparateurs de mot ' 17/07/2010 Finalement, le dernier Int32 va servir à indiquer le ' nombre de chapitres trouvés dans le document If m_bIndexerChapitre Then iVal = oDoc.colChapitres.Count bw.Write(iVal) 'iNbChapitresDoc 'oDoc.iNbCarDontSeparIndexes If m_bIndexerChapitre Then 'Dim iNbChapitresDoc% = oDoc.colChapitres.Count EcrireChapitre(bw, oDoc) 'For Each oChap As clsChapitre In oDoc.colChapitres ' bEcrireChaine(bw, oChap.sCle) ' La clé contient toutes les infos. ' bEcrireChaine(bw, oChap.sChapitre) 'Next End If Next oDoc ' Sauvegarder les mots de l'index Dim i%, iNumMot% Dim oMot As clsMot Dim de As DictionaryEntry For Each de In Me.m_htMots oMot = DirectCast(de.Value, clsMot) iNumMot += 1 If iNumMot Mod iModuloAvanvementLent = 0 Or iNumMot = iNbMots Then AfficherMessage("Sauvegarde des mots en cours : " & _ iNumMot & " / " & iNbMots) If m_bInterrompre Then GoTo Interruption End If bEcrireChaine(bw, oMot.sMot) bw.Write(oMot.iNbOccurrences) bw.Write(oMot.iNbPhrases) ' Nombre de phrases dans lesquelles ce mot figure For i = 1 To oMot.iNbPhrases bw.Write(oMot.iLireNumPhrase(i)) Next i Next de 'oMot ' Sauvegarder les phrases de l'index Dim oPhrase As clsPhrase Dim iNumPhrase As Integer For Each oPhrase In m_colPhrases 'For Each de In m_colPhrases ' oPhrase = DirectCast(de.Value, clsPhrase) iNumPhrase = iNumPhrase + 1 If iNumPhrase Mod iModuloAvanvementLent = 0 Or iNumPhrase = Me.iNbPhrasesG Then AfficherMessage("Sauvegarde des phrases en cours : " & _ iNumPhrase & " / " & Me.iNbPhrasesG) If m_bInterrompre Then GoTo Interruption End If bEcrireChaine(bw, oPhrase.sClePhrase) bEcrireChaine(bw, oPhrase.sCleDoc) If m_bIndexerChapitre Then _ bEcrireChaine(bw, oPhrase.sCodeChapitre) bw.Write(oPhrase.iNumParagrapheL) bw.Write(oPhrase.iNumPhraseG) bw.Write(oPhrase.iNumPhraseL) bEcrireChaine(bw, oPhrase.sPhrase) Next oPhrase ' de End Using ' bw.Close() 'End Using ' fs.Close() bSauvegarderIndex = True Catch ex As Exception AfficherMsgErreur2(ex, "bSauvegarderIndex") 'Finally ' If Not IsNothing(fs) Then fs.Close() End Try Interruption: If m_bInterrompre Then ' Ne pas conserver un fichier partiel If bFichierExiste(sCheminFichierIndex) Then bSupprimerFichier(sCheminFichierIndex) End If End If Sablier(bDesactiver:=True) End Function Private Sub EcrireChapitre(bw As IO.BinaryWriter, oDoc As clsDoc) For Each oChap As clsChapitre In oDoc.colChapitres bEcrireChaine(bw, oChap.sCle) ' La clé contient toutes les infos. bEcrireChaine(bw, oChap.sChapitre) Next End Sub Public Function bLireIndex() As Boolean ' Lire l'index VBTxtFinder.idx bLireIndex = False Dim rVersionFichier As Single Dim lNbMots As Integer If Not bFichierExiste(m_sCheminVBTxtFndIdx) Then Return False If m_bFichierIndexDef Then Dim iReponse% = MsgBox("Voulez-vous recharger l'index :" & vbLf & _ m_sCheminVBTxtFndIdx & " ?", MsgBoxStyle.YesNo Or MsgBoxStyle.Question, _ sMsgGestionIndex) If iReponse = MsgBoxResult.No Then Return False End If Sablier() AfficherMessage("Lecture de l'index en cours...") m_bIndexModifie = False Dim sMsgErr$ = "" Dim bRecommencer As Boolean = False Recommencer: Dim iEncodage% = iCodePageWindowsLatin1252 If m_bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 Dim fs As IO.FileStream = Nothing Try fs = New IO.FileStream(m_sCheminVBTxtFndIdx, IO.FileMode.Open, IO.FileAccess.Read) Using br As New IO.BinaryReader(fs, Encoding.GetEncoding(iEncodage)) Dim sMsgErrLecture$ = "Version de fichier incorrecte : " & vbLf & m_sCheminVBTxtFndIdx rVersionFichier = br.ReadSingle() If rVersionFichier <> rVersionFichierVBTxtFndIdx And _ rVersionFichier <> rVersionFichierVBTxtFndIdx10 Then sMsgErr = sMsgErrLecture sMsgErr &= vbLf & "Version = " & rVersionFichier & " <> " & _ rVersionFichierVBTxtFndIdx & " attendu." GoTo Erreur End If m_bIndexerChapitre = True Dim bVersion1p0 As Boolean = False If rVersionFichier = rVersionFichierVBTxtFndIdx10 Then bVersion1p0 = True m_bIndexerChapitre = False End If Dim iNbDocs%, iNb% iNbDocs = br.ReadInt32() sMsgErrLecture = "Aucun document trouvé dans : " & m_sCheminVBTxtFndIdx If iNbDocs = 0 Then GoTo Erreur lNbMots = br.ReadInt32() sMsgErrLecture = "Auncun mot trouvé dans : " & m_sCheminVBTxtFndIdx If lNbMots = 0 Then GoTo Erreur Me.iNbPhrasesG = br.ReadInt32() sMsgErrLecture = "Aucune phrase trouvée dans : " & m_sCheminVBTxtFndIdx If Me.iNbPhrasesG = 0 Then GoTo Erreur Me.iNbParagG = br.ReadInt32() Me.iNbMotsG = br.ReadInt32() ' Non : Place réservée pour compléter les statistiques générales dans une ' version future (afin de conserver la compatibilité du fichier index) ' Nombre de caractères dont les séparateurs de mot ' 22/05/2010 Place utilisée pour l'encodage bRecommencer = False 'Dim iUnicode% = br.ReadInt32() Dim iOptionsEncodage% = br.ReadInt32() Dim bUnicode As Boolean = (iOptionsEncodage And iMasqueOptionUnicode) > 0 Dim bAccents As Boolean = (iOptionsEncodage And iMasqueOptionAccent) > 0 'MsgBox("Encodage unicode = " & iUnicode) If bUnicode And Not m_bOptionTexteUnicode Then m_bOptionTexteUnicode = True bRecommencer = True ElseIf Not bUnicode And m_bOptionTexteUnicode Then m_bOptionTexteUnicode = False bRecommencer = True End If If bAccents And Not m_bIndexerAccents Then m_bIndexerAccents = True bRecommencer = True ElseIf Not bAccents And m_bIndexerAccents Then m_bIndexerAccents = False bRecommencer = True End If If bRecommencer Then GoTo FinUsing If m_bIndexerChapitre Then m_sbChapitres = New StringBuilder Dim sCheminDoc$ = "", sCleDoc$ = "", sCodeDoc$ = "" sMsgErrLecture = "Impossible de lire les documents du fichier : " & _ m_sCheminVBTxtFndIdx & vbLf & _ "Cause possible : l'encodage ne correspond pas à celui attendu." For i = 0 To iNbDocs - 1 If Not bLireChaine(br, sCleDoc) Then sMsgErr = sMsgErrLecture : GoTo Erreur If Not bLireChaine(br, sCodeDoc) Then sMsgErr = sMsgErrLecture : GoTo Erreur If Not bLireChaine(br, sCheminDoc) Then sMsgErr = sMsgErrLecture : GoTo Erreur ' 24/05/2019 Voir si on peut trouver l'info. sur Unicode dans le fichier ini ' (il faudrait sauver l'info. dans l'index) Dim bDocUnicode As Boolean = False If Me.m_colDocsIni.Contains(sCodeDoc) Then bDocUnicode = DirectCast(Me.m_colDocsIni(sCodeDoc), clsDoc).bTxtUnicode End If ' Place réservée pour compléter les statistiques par document iNb = br.ReadInt32() ' oDoc.iNbMotsIndexes = iNb iNb = br.ReadInt32() ' oDoc.iNbPhrasesIndexees = iNb iNb = br.ReadInt32() ' oDoc.iNbParagIndexes = iNb iNb = br.ReadInt32() ' oDoc.iNbCarIndexes = iNb ' 17/07/2010 Finalement, le dernier Int32 va servir à indiquer le ' nombre de chapitres trouvés dans le document Dim iNbChapitresDuDoc% = br.ReadInt32() ' Non : oDoc.iNbCarDontSeparIndexes = iNb Dim colChapitres As Collection = Nothing If m_bIndexerChapitre Then colChapitres = New Collection ' Il faut sauver les chapitres dans la boucle des documents ' car si aucun chapitre, il faut pouvoir l'indiqer : m_sbChapitres.AppendLine(vbCrLf & sCheminDoc & " (" & sCodeDoc & ") :") sMsgErrLecture = "Impossible de lire les chapitres du fichier : " & _ m_sCheminVBTxtFndIdx For j0 As Integer = 1 To iNbChapitresDuDoc Dim sChapitre$ = "" Dim sCle$ = "" If Not bLireChaine(br, sCle) Then sMsgErr = sMsgErrLecture : GoTo Erreur If Not bLireChaine(br, sChapitre) Then sMsgErr = sMsgErrLecture : GoTo Erreur Dim chap As New clsChapitre chap.sCle = sCle ' sCleDoc & ":" & chap.sCodeChapitre Dim asChamps$() = sCle.Split(":"c) Dim sCleDoc0$ = asChamps(0) Dim sCodeChap0$ = asChamps(1) chap.sCodeChapitre = sCodeChap0 chap.sCleDoc = sCleDoc0 chap.sCodeDoc = sCodeDoc 'sLireCodeDoc(sCleDoc) chap.sChapitre = sChapitre colChapitres.Add(chap, chap.sCle) m_sbChapitres.AppendLine(sCodeChap0 & " : " & sChapitre) Next End If ' Pour le moment l'info. n'est pas dans l'index (mais dans le fichier ini oui) 'Const bTxtUnicode As Boolean = False ' 26/01/2019 ' On peut cependant lire l'info. dans le fichier ini (en attendant de le sauver dans l'index) Dim bTxtUnicode = bDocUnicode ' 24/05/2019 If Not bAjouterDocument(sCleDoc, sCodeDoc, sCheminDoc, bTxtUnicode, colChapitres) Then sMsgErr = sMsgErrLecture & vbLf & "Impossible d'ajouter le document" GoTo Erreur End If Next i Dim lPosFinFichier, lPosFichier As Long lPosFinFichier = fs.Length Dim oMot As clsMot Dim sMot$ = "" Dim j, iNbPhrases As Integer sMsgErrLecture = "Impossible de lire les mots du fichier : " & _ m_sCheminVBTxtFndIdx For i = 0 To lNbMots - 1 ' Afficher la progression de la lecture ' Pour les 100 premiers mots, le nombre de phrases peut être elevé If i Mod iModuloAvanvementLent = 0 Or i = lNbMots - 1 Or i < 100 Then lPosFichier = fs.Position Dim rPC! = 100 If lPosFinFichier <> 0 Then rPC = CInt(100.0! * lPosFichier / lPosFinFichier) ' 05/05/2018 AfficherMessage("Lecture de l'index (mots) en cours... " & rPC & "%") If m_bInterrompre Then GoTo Fin End If ' Lecture du mot If Not bLireChaine(br, sMot) Then sMsgErr = sMsgErrLecture : GoTo Erreur ' Si on récupère un index de la version VB6, faire attention : ' D'abord vérifier rapidement si le mot est indexé tel quel ' (si le mot n'a pas d'accent, cette vérification est rapide) Dim sCle$ = sMot.ToLower Dim sCleAvecAccent$ = sCle Dim sCleSansAccent$ = "" Dim bCleExiste As Boolean = Me.m_htMots.ContainsKey(sCle) ' Si l'index provient de VB6, on ne peut pas savoir ' si le mot est avec ou sans accent ' Optimisation : oublier la compatibilité VB6 pour accélérer le ' chargement de l'index If Not bCleExiste Or Not m_bIndexerAccents Then sCleSansAccent = sEnleverAccents(sMot) End If ' Vérifier si le mot est indexé sans les accents If Not bCleExiste And Not m_bIndexerAccents Then If String.Compare(sCleSansAccent, sMot) <> 0 Then bCleExiste = Me.m_htMots.ContainsKey(sCleSansAccent) If bCleExiste Then sCle = sCleSansAccent End If End If ' Si la clé sans accent existe déjà, cela signifie qu'il s'agit d'un index ' en provenance de VB6 (ou DotNet avec les accents et plus maintenant) ' dans lequel un mot accentué à déjà été ajouté avec une clé sans accent ' Dans ce cas, on fusionne les informations sur les mots, ' pour que la recherche continue à trouver tous les résultats If bCleExiste Then m_bIndexModifie = True oMot = DirectCast(Me.m_htMots.Item(sCle), clsMot) oMot.iNbOccurrences += br.ReadInt32() ' Ajouts des occurences des 2 mots iNbPhrases = br.ReadInt32() ' Nombre de phrases dans lesquelles ce mot figure For j = 1 To iNbPhrases ' Ajout des n° de phrase des 2 mots oMot.AjouterNumPhrase3(br.ReadInt32()) Next j Dim sCleMotIndexe$ = oMot.sMot.ToLower If oMot.sMot.ToLower <> sCleSansAccent Then ' Pour VB6, il suffit de noter le mot lui-même sans les accents ' la clé est déjà sans les accents oMot.sMot = sCleSansAccent If m_bIndexerAccents Then ' Enlever le mot et le réindexer sans les accents Me.m_htMots.Remove(sCle) Me.m_htMots.Add(sCleSansAccent, oMot) End If End If Else oMot = New clsMot oMot.iNbOccurrences = br.ReadInt32() iNbPhrases = br.ReadInt32() ' Nombre de phrases dans lesquelles ce mot figure oMot.RedimPhrases(iNbPhrases) For j = 1 To iNbPhrases oMot.AjouterNumPhrase3(br.ReadInt32()) Next j ' Ajouter le mot dans le hastable oMot.sMot = sMot If m_bIndexerAccents Then Me.m_htMots.Add(sCleAvecAccent, oMot) Else Me.m_htMots.Add(sCleSansAccent, oMot) End If End If Next i sMsgErrLecture = "Impossible de lire les phrases du fichier : " & _ m_sCheminVBTxtFndIdx Dim oPhrase As clsPhrase Dim sChaine$ = "" Dim iMemNumParagrapheL% = 0 Dim iNumParagrapheG% = 0 For i = 0 To Me.iNbPhrasesG - 1 ' Afficher la progression de la lecture If i Mod iModuloAvanvementLent = 0 Or i = Me.iNbPhrasesG - 1 Then lPosFichier = fs.Position AfficherMessage("Lecture de l'index (phrases) en cours... " & _ CInt(100.0! * lPosFichier / lPosFinFichier) & "%") If m_bInterrompre Then GoTo Fin End If oPhrase = New clsPhrase If Not bLireChaine(br, sChaine) Then sMsgErr = sMsgErrLecture : GoTo Erreur oPhrase.sClePhrase = sChaine If Not bLireChaine(br, sChaine) Then sMsgErr = sMsgErrLecture : GoTo Erreur oPhrase.sCleDoc = sChaine oPhrase.sCodeChapitre = "" If Not bVersion1p0 Then If Not bLireChaine(br, sChaine) Then sMsgErr = sMsgErrLecture : GoTo Erreur oPhrase.sCodeChapitre = sChaine End If oPhrase.iNumParagrapheL = br.ReadInt32() ' En déduire le n° de § global If iMemNumParagrapheL <> oPhrase.iNumParagrapheL Then iNumParagrapheG += 1 End If oPhrase.iNumParagrapheG = iNumParagrapheG iMemNumParagrapheL = oPhrase.iNumParagrapheL oPhrase.iNumPhraseG = br.ReadInt32() oPhrase.iNumPhraseL = br.ReadInt32() If Not bLireChaine(br, sChaine) Then sMsgErr = sMsgErrLecture : GoTo Erreur oPhrase.sPhrase = sChaine m_colPhrases.Add(oPhrase) Me.iNbPhrasesG = oPhrase.iNumPhraseG Next i LireListeDocumentsIndexesIni() AfficherMessage(sMsgOperationTerminee) bLireIndex = True FinUsing: End Using 'br.Close() 'End Using 'fs.Close() Catch ex As Exception AfficherMsgErreur2(ex, "bLireIndex", sMsgErr) 'Finally ' If Not IsNothing(fs) Then fs.Close() End Try If bRecommencer Then GoTo Recommencer Fin: Sablier(bDesactiver:=True) Exit Function Erreur: Sablier(bDesactiver:=True) 'MsgBox(sMsgErr, MsgBoxStyle.Critical, "bLireIndex") AfficherMsgErreur("bLireIndex", sMsgErr) End Function #End Region #Region "Création des documents index sous Word" Private Function bInitMotsCourants(sCodeLangIndex$, ByRef sMotsCourants$) As Boolean Dim sChemin$ = Application.StartupPath & sCheminMotsCourants & "_" & sCodeLangIndex & sExtTxt If sCodeLangIndex = sCodeLangueFr Then If bFichierExiste(sChemin) Then sMotsCourants = sLireFichier(sChemin) Else sMotsCourants = Config.sMotsCourantsFr End If Else If Not bFichierExiste(sChemin, bPrompt:=True) Then Return False sMotsCourants = sLireFichier(sChemin) End If If Not m_bIndexerAccents Then sMotsCourants = sEnleverAccents(sMotsCourants) Return True End Function Private Sub ReinitDicoAccentOuPas() ' Réindexer les documents avec ou sans les accents m_htMots = New Hashtable(m_styleCompare) m_colPhrases = New ArrayList m_htDico = Nothing End Sub Public Sub ReinitDico() m_htDico = Nothing ' 03/05/2014 Penser à recharger le dico si on change de langue End Sub Private Function bInitDico(sCheminDico0$) As Boolean If Not bFichierExiste(sCheminDico0, bPrompt:=True) Then Return False AfficherMessage("Chargement du dictionnaire en cours...") m_htDico = CreateCaseInsensitiveHashtable() Dim asLignes() = sLireFichier(sCheminDico0).Split(CChar(vbCrLf)) For Each sLigne0 In asLignes Dim sMot = sLigne0.Trim Dim sCle = "" If m_bIndexerAccents Then sCle = sMot.ToLower Else sCle = sEnleverAccents(sMot) End If If m_htDico.ContainsKey(sCle) Then If m_bIndexerAccents Then Debug.WriteLine("Doublon : " & sCle) Else m_htDico.Add(sCle, sMot) End If Next Return True End Function Private Function bMotDico(sMot$) As Boolean If IsNothing(m_htDico) Then Return False If m_bIndexerAccents Then Return m_htDico.ContainsKey(sMot) End If Dim sMotSansAccent$ = sEnleverAccents(sMot) Return m_htDico.ContainsKey(sMotSansAccent) End Function Private Sub CreerDocIndexSimple(bMotsCourants As Boolean, sCodeLangIndex$, _ bNumeriques As Boolean, bMotsDico As Boolean, sCheminDico0$) ' Fabriquer un index simple à partir de la collection de mots indexés Dim sMotsCourants$ = "" If Not bMotsCourants Then If Not bInitMotsCourants(sCodeLangIndex, sMotsCourants) Then Exit Sub End If If Not bMotsDico AndAlso IsNothing(m_htDico) Then If Not bInitDico(sCheminDico0) Then Exit Sub End If Dim sCheminTxt = m_sCheminDossierCourant & "\" & _ sPrefixeIndexSimple & "_" & sCodeLangIndex & sExtTxt Dim sb As New StringBuilder Dim sl As New SortedList(CaseInsensitiveComparer.Default) Dim de As DictionaryEntry For Each de In Me.m_htMots Dim oMot As clsMot = DirectCast(de.Value, clsMot) Dim sCleMot$ = DirectCast(de.Key, String) If m_bIndexerAccents Then sCleMot = sCleMot.ToLower Else ' Enlever les accents comme pour la liste des mots courants sCleMot = sEnleverAccents(sCleMot) End If If Not bMotsCourants AndAlso InStr(sMotsCourants, " " & sCleMot & " ") > 0 Then Continue For End If If Not bMotsDico AndAlso bMotDico(oMot.sMot) Then Continue For Dim sMotGlossaire$ = oMot.sMot Dim sCle$ = sMotGlossaire If Not bNumeriques Then ' Exclusion des numériques If IsNumeric(sCle) Then Continue For End If If Not sl.Contains(sCle) Then sl.Add(sCle, sMotGlossaire) MotSuivant: Next de 'oMot For Each de In sl Dim sLigne$ = DirectCast(de.Value, String) sb.Append(sLigne).Append(vbCrLf) Next de If Not bEcrireFichier(sCheminTxt, sb) Then Exit Sub ProposerOuvrirFichier(sCheminTxt) End Sub Public Sub ComparerIndexSimple(sCodesLanguesIndex$) ' Fabriquer une liste de mots communs à deux index simples ' par ex. index fr et anglais du même texte : extraction des mots propres Dim asCodesLangues$() = sCodesLanguesIndex.Split(";".ToCharArray()) Dim iNbCodesLangues% = 0 Dim sCodeLangue1$ = "" For Each sCodeLangue As String In asCodesLangues If sCodeLangue.Length = 0 Then Continue For If sCodeLangue1.Length = 0 Then sCodeLangue1 = sCodeLangue 'MsgBox(sCodeLangue) iNbCodesLangues += 1 Next If iNbCodesLangues < 2 Then MsgBox("Il faut au moins 2 codes langues dans la liste pour faire une intersection", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If Dim iNbIndex% = 0 Dim sCheminTxt1 = m_sCheminDossierCourant & "\" & _ sPrefixeIndexSimple & "_" & sCodeLangue1 & sExtTxt If Not bFichierExiste(sCheminTxt1, bPrompt:=True) Then Exit Sub iNbIndex += 1 ' D'abord charger l'index simple du 1er code langue Dim asLignes$() = asLireFichier(sCheminTxt1) Dim ht As Hashtable ht = CreateCaseInsensitiveHashtable() Dim htNbLang As Hashtable ' Compter le nombre de langues trouvées htNbLang = CreateCaseInsensitiveHashtable() Dim htLang As Hashtable ' Liste des langues trouvées htLang = CreateCaseInsensitiveHashtable() For Each sLigne As String In asLignes Dim sMot$ = sLigne If htNbLang.ContainsKey(sMot) Then ' On parcours le 1er index : on ne passe jamais ici car pas de doublon Dim iNbLang% = DirectCast(htNbLang(sMot), Integer) htNbLang(sMot) = (iNbLang + 1) Else htNbLang.Add(sMot, 1%) htLang.Add(sMot, sCodeLangue1) End If If ht.ContainsKey(sMot) Then Continue For ht.Add(sMot, sMot) Next ' Ensuite parcourir tous les codes langues présents dans la liste For Each sCodeLangue As String In asCodesLangues If sCodeLangue = sCodeLangue1 Then Continue For Dim sCheminTxt2 = m_sCheminDossierCourant & _ "\" & sPrefixeIndexSimple & "_" & sCodeLangue & sExtTxt If Not bFichierExiste(sCheminTxt2) Then Continue For ' Ensuite faire l'intersection de l'index simple du 1er code langue ' avec ceux qui existent dans les autres langues iNbIndex += 1 Dim sb As New StringBuilder asLignes = asLireFichier(sCheminTxt2) For Each sLigne As String In asLignes Dim sMot$ = sLigne If Not ht.ContainsKey(sMot) Then Continue For sb.Append(sMot).Append(vbCrLf) ' Mot commun aux 2 index If htNbLang.ContainsKey(sMot) Then Dim iNbLang% = DirectCast(htNbLang(sMot), Integer) htNbLang(sMot) = (iNbLang + 1) Dim sLang$ = DirectCast(htLang(sMot), String) htLang(sMot) = sLang & ";" & sCodeLangue Else htNbLang.Add(sMot, 1%) htLang.Add(sMot, sCodeLangue) End If Next sLigne Dim sCheminTxt = m_sCheminDossierCourant & "\" & _ sPrefixeIndexSimple & "_" & _ sCodeLangue1 & "_" & sCodeLangue & sExtTxt If Not bEcrireFichier(sCheminTxt, sb) Then Exit Sub ProposerOuvrirFichier(sCheminTxt) Next sCodeLangue If iNbIndex < 2 Then MsgBox("Il faut au moins 2 index simples dans 2 codes langues de la liste pour faire une intersection", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If If iNbIndex >= 3 Then ' Afficher le nombre de langues trouvées par mots communs (à au moins 2 langues) Dim sb As New StringBuilder Dim ht2 As New Hashtable Dim sbDetail As New StringBuilder For Each de As DictionaryEntry In htNbLang Dim iNbLang% = DirectCast(de.Value, Integer) If iNbLang < 2 Then Continue For Dim sMot$ = DirectCast(de.Key, String) ' Dans l'index final ajouter tous les mots communs à tous les index (chaque langue) If iNbLang = iNbIndex Then ht2.Add(sMot, sMot) ' sb.Append(sMot).Append(vbCrLf) Dim sLang$ = DirectCast(htLang(sMot), String) sbDetail.Append(sMot & ":" & iNbLang & ":" & sLang).Append(vbCrLf) Next Dim sl As New SortedList(ht2) For i As Integer = 0 To sl.Count - 1 Dim sMot$ = DirectCast(sl.GetByIndex(i), String) sb.Append(sMot).Append(vbCrLf) Next Dim sCheminTxt = m_sCheminDossierCourant & "\" & _ sPrefixeIndexSimple & sExtTxt If Not bEcrireFichier(sCheminTxt, sb) Then Exit Sub ProposerOuvrirFichier(sCheminTxt) sCheminTxt = m_sCheminDossierCourant & "\" & _ sPrefixeIndexSimple & "_Detail" & sExtTxt If Not bEcrireFichier(sCheminTxt, sbDetail) Then Exit Sub 'ProposerOuvrirFichier(sCheminTxt) End If End Sub Public Sub CreerDocIndexMajuscules() ' Lister les majuscules intempestives Dim sCheminHtml = m_sCheminDossierCourant & "\" & sPrefixeMajuscules & sExtHtm Dim sb As New StringBuilder Const sEnteteHtml$ = "<html><body>" Const sPiedHtml$ = "</body></html>" Const sSautLigneHtml$ = "<br>" & vbCrLf sb.Append(sEnteteHtml) sb.Append("<style type=" & sGm & "text/css" & sGm & _ ">SPAN.Jaune { BACKGROUND-COLOR: yellow }</style>") ' Mettre en couleur les majuscules intempestives trouvées dans le document Const sBaliseOuv$ = "<SPAN class='Jaune'>" Const sBaliseFerm$ = "</SPAN>" Dim bAuMoins1Maj As Boolean = False ' intempestive For Each oPhrase As clsPhrase In Me.m_colPhrases Dim sPhrase$ = oPhrase.sPhrase.Trim Dim sbPhrase As New StringBuilder Dim bAuMoins1MajPhrase = False ' intempestive Dim iMemPosDebOcc% = 0 Dim iDebRechOcc% = 0 Dim iLong% = 0 Dim iMemLong% = 0 Dim bMemOccIntempest As Boolean = False Do Dim iPosDebOcc% = sPhrase.IndexOfUppercase(iDebRechOcc) If iPosDebOcc = -1 Then Exit Do If iPosDebOcc = 0 Then ' Majuscule en début de phrase : normal iDebRechOcc = iPosDebOcc + 1 Dim sPortionAv1$ = sPhrase.Substring(0, 1) sbPhrase.Append(sPortionAv1) iLong = 1 bMemOccIntempest = False GoTo Suite End If bAuMoins1Maj = True bAuMoins1MajPhrase = True Dim iLongPortionAv% = iPosDebOcc - iMemPosDebOcc - iMemLong Dim sPortionAv$ = sPhrase.Substring(iDebRechOcc, iLongPortionAv) sbPhrase.Append(sPortionAv) iLong = 1 Dim sOccurrence$ = sPhrase.Substring(iPosDebOcc, 1) sbPhrase.Append(sBaliseOuv & sOccurrence & sBaliseFerm) iDebRechOcc = iPosDebOcc + iLong bMemOccIntempest = True Suite: iMemPosDebOcc = iPosDebOcc iMemLong = iLong Loop While True If bAuMoins1MajPhrase Then Dim sFin$ = sPhrase.Substring(iMemPosDebOcc + iLong) sbPhrase.Append(sFin) Dim sAjout$ = sbPhrase.ToString sb.Append(sAjout) sb.Append(sSautLigneHtml) End If Next If Not bAuMoins1Maj Then MsgBox("Aucune majuscule intempestive trouvée dans ce document !", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If sb.Append(sPiedHtml) ' 26/10/2019 Tous les documents html doivent être en UTF8 (ça doit être l'encodage html par défaut) If Not bEcrireFichier(sCheminHtml, sb, bEncodageUTF8:=True) Then Exit Sub ProposerOuvrirFichier(sCheminHtml) End Sub Public Sub CreerDocIndexEspInsec(bTous As Boolean) ' Lister les espaces insécables à vérifier ou bien tous les espaces insécables Dim sCheminHtml = m_sCheminDossierCourant & "\" & _ sPrefixeEspacesInsecables & sExtHtm Dim sb As New StringBuilder Const sEnteteHtml$ = "<html><body>" Const sPiedHtml$ = "</body></html>" Const sSautLigneHtml$ = "<br>" & vbCrLf sb.Append(sEnteteHtml) sb.Append("<style type=" & sGm & "text/css" & sGm & _ ">SPAN.Jaune { BACKGROUND-COLOR: yellow }</style>") ' Mettre en couleur les espaces insécables trouvés dans le document Const sBaliseOuv$ = "<SPAN class='Jaune'>" Const sBaliseFerm$ = "</SPAN>" Dim cCarEspaceInsec As Char = Chr(iCodeASCIIEspaceInsecable) Dim sListeCarPrecedOk$ = "«—" Dim sListeCarSuivOk$ = "»:;?!%" Dim bAuMoins1EspInsec As Boolean = False Dim bAuMoins1EspInsecAVerif As Boolean = False For Each oPhrase As clsPhrase In Me.m_colPhrases If oPhrase.sPhrase.IndexOf(cCarEspaceInsec) = -1 Then Continue For Dim sPhrase$ = oPhrase.sPhrase.Trim Dim sbPhrase As New StringBuilder Dim bAuMoins1EspInsecAVerifPhrase = False Dim iMemPosDebOcc% = 0 Dim iDebRechOcc% = 0 Dim iLong% = 0 Dim iMemLong% = 0 Dim bMemOccAVerifier As Boolean = False ' 19/03/2016 Do Dim iPosDebOcc% = sPhrase.IndexOf(cCarEspaceInsec, iDebRechOcc) If iPosDebOcc = -1 Then Exit Do ' On ne peut pas surligner un espace après un espace en html ? Dim sSoulignerEspaceAvInsec$ = " " ' 19/05/2019 Possibilité d'afficher tous les espaces insécables If Not bTous AndAlso iPosDebOcc >= 0 Then ' 19/03/2016 1->0 ' Vérifier le car. précédant Dim sCarPreced$ = sPhrase.Substring(iPosDebOcc - 1, 1) If sListeCarPrecedOk.Contains(sCarPreced) Then iDebRechOcc = iPosDebOcc + 1 Dim iDec% = 0 If bMemOccAVerifier Then iDec = 1 Dim iLongPortionAv1% = iDebRechOcc - iMemPosDebOcc - iDec Dim sPortionAv1$ = sPhrase.Substring(iMemPosDebOcc + iDec, iLongPortionAv1) sbPhrase.Append(sPortionAv1) iLong = 1 bMemOccAVerifier = False GoTo Suite End If bAuMoins1EspInsec = True If sCarPreced = " " Then sSoulignerEspaceAvInsec = "_" End If ' 19/05/2019 Possibilité d'afficher tous les espaces insécables If Not bTous AndAlso iPosDebOcc < sPhrase.Length Then ' Vérifier le car. suivant Dim sCarSuivant$ = sPhrase.Substring(iPosDebOcc + 1, 1) If sListeCarSuivOk.Contains(sCarSuivant) Then iDebRechOcc = iPosDebOcc + 1 Dim iLongPortionAv1% = iDebRechOcc - iMemPosDebOcc - 1 Dim sPortionAv1$ = sPhrase.Substring(iMemPosDebOcc + 1, iLongPortionAv1) sbPhrase.Append(sPortionAv1) iLong = 1 bMemOccAVerifier = False GoTo Suite End If bAuMoins1EspInsec = True End If bAuMoins1EspInsec = True bAuMoins1EspInsecAVerif = True bAuMoins1EspInsecAVerifPhrase = True Dim iLongPortionAv% = iPosDebOcc - iMemPosDebOcc - iMemLong Dim sPortionAv$ = sPhrase.Substring(iDebRechOcc, iLongPortionAv) sbPhrase.Append(sPortionAv) iLong = 1 Dim sOccurrence$ = sSoulignerEspaceAvInsec sbPhrase.Append(sBaliseOuv & sOccurrence & sBaliseFerm) iDebRechOcc = iPosDebOcc + iLong ' Occurrence à vérifier : non conforme à sListeCarPrecedOk et sListeCarSuivOk bMemOccAVerifier = True Suite: iMemPosDebOcc = iPosDebOcc iMemLong = iLong Loop While True If bAuMoins1EspInsecAVerifPhrase Then Dim sFin$ = sPhrase.Substring(iMemPosDebOcc + iLong) sbPhrase.Append(sFin) Dim sAjout$ = sbPhrase.ToString sb.Append(sAjout) sb.Append(sSautLigneHtml) End If Next If Not bTous AndAlso Not bAuMoins1EspInsecAVerif Then MsgBox("Aucun espace insécable à vérifier trouvé dans ce document !", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If If bTous AndAlso Not bAuMoins1EspInsec Then MsgBox("Aucun espace insécable trouvé dans ce document !", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If sb.Append(sPiedHtml) ' 26/10/2019 Tous les documents html doivent être en UTF8 (ça doit être l'encodage html par défaut) If Not bEcrireFichier(sCheminHtml, sb, bEncodageUTF8:=True) Then Exit Sub ProposerOuvrirFichier(sCheminHtml) End Sub Public Sub CreerDocIndexCitations() ' Fabriquer un index des citations Dim sCheminTxt = m_sCheminDossierCourant & "\" & _ sPrefixeIndexCitations & sExtTxt Dim sb As New StringBuilder Dim sSepGm$ = Chr(iCodeASCIIGuillemet) Dim sSepQuote$ = Chr(iCodeASCIIQuote) Dim sSepGmO$ = Chr(iCodeASCIIGuillemetOuvrant) Dim sSepGmF$ = Chr(iCodeASCIIGuillemetFermant) Dim sSepGmO2$ = Chr(iCodeASCIIGuillemetOuvrant2) Dim sSepGmF2$ = Chr(iCodeASCIIGuillemetFermant2) Dim sSepGmO3$ = Chr(iCodeASCIIGuillemetOuvrant3) Dim sSepGmF3$ = Chr(iCodeASCIIGuillemetFermant3) Dim sSepGmO4$ = Chr(iCodeASCIIGuillemetOuvrant4) Dim sSepGmF4$ = Chr(iCodeASCIIGuillemetFermant4) Dim sSepGmO5$ = Chr(iCodeASCIIGuillemetOuvrant5) Dim sSepGmF5$ = Chr(iCodeASCIIGuillemetFermant5) Dim sListeSepCitations$ = sSepGm & sSepQuote & _ sSepGmO & sSepGmF & sSepGmO2 & sSepGmF2 & sSepGmO3 & sSepGmF3 & _ sSepGmO4 & sSepGmF4 & sSepGmO5 & sSepGmF5 Dim acSepGm = sSepGm.ToCharArray Dim acSepQuote = sSepQuote.ToCharArray 'Dim acSepGmO = sSepGmO.ToCharArray 'Dim acSepGmF = sSepGmF.ToCharArray Dim bAuMoins1CitationTot As Boolean = False For Each oPhrase As clsPhrase In Me.m_colPhrases If oPhrase.sPhrase.IndexOfAny(sListeSepCitations.ToCharArray) = -1 Then _ Continue For Dim sPhrase$ = oPhrase.sPhrase.Trim ' Voir si indicateur citation présent au moins 2 fois dans la phrase ExtraireCitations(sPhrase, sSepGmO, sSepGmF, sb, bAuMoins1CitationTot) ExtraireCitations(sPhrase, sSepGmO2, sSepGmF2, sb, bAuMoins1CitationTot) ExtraireCitations(sPhrase, sSepGmO3, sSepGmF3, sb, bAuMoins1CitationTot) ExtraireCitations(sPhrase, sSepGmO4, sSepGmF4, sb, bAuMoins1CitationTot) ExtraireCitations(sPhrase, sSepGmO5, sSepGmF5, sb, bAuMoins1CitationTot) Dim iLen% = sPhrase.Length Dim bAuMoins1Citation As Boolean = False Dim sbTmp As StringBuilder Dim iLenSansGm = sPhrase.Replace(sSepGm, "").Length Dim iNbGm% = iLen - iLenSansGm If iNbGm <= 1 Then GoTo Suite2 bAuMoins1Citation = False sbTmp = New StringBuilder sbTmp.Append(sPhrase).Append(vbCrLf) If iNbGm = 2 Then Dim iPosGm1% = sPhrase.IndexOf(acSepGm) Dim iPosGm2% = sPhrase.LastIndexOf(acSepGm) Dim sCitation$ = sPhrase.Substring(iPosGm1 + 1, iPosGm2 - iPosGm1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If Else Dim iPos% = 0 Do Dim iPosGm1% = sPhrase.IndexOf(acSepGm, iPos) If iPosGm1 = -1 Then Exit Do Dim iPosGm2% = sPhrase.IndexOf(acSepGm, iPosGm1 + 1) If iPosGm2 = -1 Then Exit Do Dim sCitation$ = sPhrase.Substring(iPosGm1 + 1, iPosGm2 - iPosGm1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If iPos = iPosGm2 + 1 Loop While True End If If bAuMoins1Citation Then sb.Append(sbTmp) : bAuMoins1CitationTot = True Suite2: ' Vérifier que le caractère suivant n'est pas 's 'd 't 'm 'll 've Const sListeExcepAnglais$ = "stdmlv" Dim iLenSansQuotes = sPhrase.Replace(sSepQuote, "").Length Dim iNbQuotes% = iLen - iLenSansQuotes If iNbQuotes <= 1 Then GoTo Suite3 bAuMoins1Citation = False sbTmp = New StringBuilder sbTmp.Append(sPhrase).Append(vbCrLf) If iNbQuotes = 2 Then Dim iPos1% = sPhrase.IndexOf(acSepQuote) Dim iPos2% = sPhrase.LastIndexOf(acSepQuote) ' Pour les quotes, la citation doit commencer par la quote If iPos1 <> 0 Then GoTo Suite3 If iPos1 < iLen - 1 Then Dim sCarSuiv$ = sPhrase.Substring(iPos1 + 1, 1) If sCarSuiv.IndexOfAny(sListeExcepAnglais.ToCharArray) > -1 Then _ GoTo Suite3 End If If iPos2 < iLen - 1 Then Dim sCarSuiv$ = sPhrase.Substring(iPos2 + 1, 1) If sCarSuiv.IndexOfAny(sListeExcepAnglais.ToCharArray) > -1 Then _ GoTo Suite3 End If Dim sCitation$ = sPhrase.Substring(iPos1 + 1, iPos2 - iPos1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If Else Dim iPos% = 0 Dim iPos2% = -1 Do Dim iPos1% = sPhrase.IndexOf(acSepQuote, iPos) If iPos1 = -1 Then Exit Do ' Pour les quotes, la citation doit commencer par la quote 'If iPos1 <> 0 Then Continue For ' Pour la 1ère citation seulement If iPos1 <> 0 And iPos = 0 Then Exit Do If iPos1 < iLen - 1 Then Dim sCarSuiv$ = sPhrase.Substring(iPos1 + 1, 1) If sCarSuiv.IndexOfAny(sListeExcepAnglais.ToCharArray) > -1 Then _ Exit Do End If iPos2 = sPhrase.IndexOf(acSepQuote, iPos1 + 1) If iPos2 = -1 Then Exit Do If iPos2 < iLen - 1 Then Dim sCarSuiv$ = sPhrase.Substring(iPos2 + 1, 1) If sCarSuiv.IndexOfAny(sListeExcepAnglais.ToCharArray) > -1 Then _ Exit Do End If Dim sCitation$ = sPhrase.Substring(iPos1 + 1, iPos2 - iPos1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If iPos = iPos2 + 1 Loop While True End If If bAuMoins1Citation Then sb.Append(sbTmp) : bAuMoins1CitationTot = True Suite3: ' 19/01/2019 S'il y a juste " alors lister aussi If Not bAuMoins1Citation AndAlso iNbGm = 1 AndAlso sPhrase.Length > 1 Then Dim iPosGm% = sPhrase.IndexOf(acSepGm) If iPosGm > -1 AndAlso sPhrase.Length - iPosGm > 1 Then Dim sCitation = sPhrase.Substring(iPosGm, sPhrase.Length - iPosGm) sb.AppendLine(sCitation) bAuMoins1CitationTot = True End If End If Next If Not bAuMoins1CitationTot Then MsgBox("Aucune citation trouvée dans ce document !", _ MsgBoxStyle.Information, sTitreMsg) Exit Sub End If If Not bEcrireFichier(sCheminTxt, sb) Then Exit Sub ProposerOuvrirFichier(sCheminTxt) End Sub Private Sub ExtraireCitations(sPhrase$, sSepGmO$, sSepGmF$, _ sb As StringBuilder, ByRef bAuMoins1CitationTot As Boolean) ' Extraire les citations entre une paire de guillemets ouvrant et fermant distincts Dim iLen% = sPhrase.Length Dim acSepGmO = sSepGmO.ToCharArray Dim acSepGmF = sSepGmF.ToCharArray Dim iLenSansGmO = sPhrase.Replace(sSepGmO, "").Length Dim iLenSansGmF = sPhrase.Replace(sSepGmF, "").Length Dim iNbGmO% = iLen - iLenSansGmO Dim iNbGmF% = iLen - iLenSansGmF If iNbGmO = 0 Or iNbGmF = 0 Then Exit Sub Dim bAuMoins1Citation = False Dim sbTmp As New StringBuilder sbTmp.Append(sPhrase).Append(vbCrLf) If iNbGmO = 1 And iNbGmF = 1 Then Dim iPosGm1% = sPhrase.IndexOf(acSepGmO) Dim iPosGm2% = sPhrase.LastIndexOf(acSepGmF) If iPosGm2 <= iPosGm1 Then Exit Sub Dim sCitation$ = sPhrase.Substring(iPosGm1 + 1, iPosGm2 - iPosGm1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If Else Dim iPos% = 0 Do Dim iPosGm1% = sPhrase.IndexOf(acSepGmO, iPos) If iPosGm1 = -1 Then Exit Do Dim iPosGm2% = sPhrase.IndexOf(acSepGmF, iPosGm1 + 1) If iPosGm2 = -1 Then Exit Do If iPosGm2 > iPosGm1 Then Dim sCitation$ = sPhrase.Substring(iPosGm1 + 1, iPosGm2 - iPosGm1 - 1).Trim If sCitation.Length > 0 Then bAuMoins1Citation = True sbTmp.Append(vbTab & sCitation).Append(vbCrLf) End If End If iPos = iPosGm2 + 1 Loop While True End If If bAuMoins1Citation Then sb.Append(sbTmp) : bAuMoins1CitationTot = True End Sub Public Sub CreerDocIndex(sTypeIndex$, bMotsDico As Boolean, _ bMotsCourants As Boolean, sCheminDico0$, sCodeLangIndex$, _ bMotsSeulsDocIndex0 As Boolean, iMaxMotsCles%, _ bNumeriques As Boolean, sCodesLanguesIndex$, Optional bCreerDocWord As Boolean = True, Optional bProposerOuvrir As Boolean = True, Optional ByRef sCheminFinal$ = "") ' Fabriquer un index à partir de la collection de mots indexés If sTypeIndex = sIndexMajuscules Then CreerDocIndexMajuscules() Exit Sub End If If sTypeIndex = sIndexEspacesInsecables Then CreerDocIndexEspInsec(bTous:=True) Exit Sub End If If sTypeIndex = sIndexEspacesInsecablesAVerifier Then CreerDocIndexEspInsec(bTous:=False) Exit Sub End If If sTypeIndex = sIndexCitations Then CreerDocIndexCitations() Exit Sub End If If sTypeIndex = sIndexSimple Then CreerDocIndexSimple(bMotsCourants, sCodeLangIndex, bNumeriques, _ bMotsDico, sCheminDico0) Exit Sub End If If sTypeIndex = sIndexSimpleComparer Then ComparerIndexSimple(sCodesLanguesIndex) Exit Sub End If If sTypeIndex = sIndexTout Then RegenererDocs() Exit Sub End If If sTypeIndex = sIndexAccents Then AnalyseAccents(sCodeLangIndex, sCodesLanguesIndex) Exit Sub End If If Not bCreerDocIndexIntern(sTypeIndex, bMotsDico, _ bMotsCourants, sCheminDico0, sCodeLangIndex, _ bMotsSeulsDocIndex0, iMaxMotsCles, _ bNumeriques, sCodesLanguesIndex, bCreerDocWord, bProposerOuvrir, sCheminFinal) Then Exit Sub End Sub Private Function bCreerDocIndexIntern(sTypeIndex$, bMotsDico As Boolean, _ bMotsCourants As Boolean, sCheminDico0$, sCodeLangIndex$, _ bMotsSeulsDocIndex0 As Boolean, iMaxMotsCles%, _ bNumeriques As Boolean, sCodesLanguesIndex$, Optional bCreerDocWord As Boolean = True, Optional bProposerOuvrir As Boolean = True, Optional ByRef sCheminFinal$ = "") As Boolean If Not bMotsDico AndAlso IsNothing(m_htDico) Then If Not bInitDico(sCheminDico0) Then Return False End If ' Mots seuls sans afficher les occurrences Dim bMotsCles As Boolean Dim bMotsSeulsDocIndex As Boolean = bMotsSeulsDocIndex0 ' Config.bMotsSeulsDocIndex If sTypeIndex = sIndexMotsCles Then bMotsCles = True : bMotsSeulsDocIndex = True Dim sMotsCourants$ = Config.sMotsCourantsFr If Not bMotsCourants Then If Not bInitMotsCourants(sCodeLangIndex, sMotsCourants) Then Return False End If If Not m_bIndexerAccents Then sMotsCourants = sEnleverAccents(sMotsCourants) Dim bTriFreq As Boolean If sTypeIndex <> sIndexAlpha Then bTriFreq = True Dim sTitre$, sListeMax$ Dim sExplication$ = "" Dim iNbDocIndexes% = Me.m_colDocs.Count() Dim sAccent$ = "" If Me.m_bIndexerAccents Then sAccent = "avec les accents " ' 06/06/2019 sTitre = "Document index " & sAccent & "de VBTextFinder" If Not bMotsDico And Not bMotsCourants Then sTitre = "Document index " & sAccent & "(hors mots du dictionnaire et mots courants " & _ sCodeLangIndex & ") de VBTextFinder" ElseIf Not bMotsDico Then sTitre = "Document index " & sAccent & "(hors mots du dictionnaire " & _ sCodeLangIndex & ") de VBTextFinder" ' 16/01/2011 Manque une ) ici ElseIf Not bMotsCourants Then sTitre = "Document index " & sAccent & "(hors mots courants " & _ sCodeLangIndex & ") de VBTextFinder" End If sListeMax = "" If Not bMotsCles Then sListeMax = _ "liste des codes documents - " & iNbOccurrencesMaxListe & _ " au max. - pour les mots non fréquents <= " & _ iNbOccurencesMaxRecherchees & " occurrences" If iNbDocIndexes = 1 Then sListeMax = "" If bTriFreq Then sTitre &= " trié en fréquence" If bMotsSeulsDocIndex Then sTitre &= _ " sans les mots courants : mots clés" If Not bMotsSeulsDocIndex Then _ sExplication = "Explication : Nombre d'occurrences : Mot" If sListeMax <> "" Then sExplication &= " (" & sListeMax & ")" Else sTitre &= " trié par ordre alphabétique" If Not bMotsSeulsDocIndex Then _ sExplication = "Explication : Mot (nombre d'occurrences" If sListeMax <> "" Then sExplication &= " : " & sListeMax If Not bMotsSeulsDocIndex Then sExplication &= ")" End If sExplication = sExplication & vbLf ' Si le fichier existe, le supprimer avant Dim sCheminTxt = m_sCheminDossierCourant & "\" & sFichierVBTxtFndAlphab & sExtTxt If bTriFreq Then sCheminTxt = m_sCheminDossierCourant & "\" & _ sFichierVBTxtFndFreq & sExtTxt If bMotsCles Then sCheminTxt = m_sCheminDossierCourant & "\" & _ sFichierVBTxtFndMotsCles & sExtTxt Dim sCheminDoc = m_sCheminDossierCourant & "\" & sFichierVBTxtFndAlphab & sExtDoc If bTriFreq Then sCheminDoc = m_sCheminDossierCourant & "\" & _ sFichierVBTxtFndFreq & sExtDoc If bMotsCles Then sCheminDoc = m_sCheminDossierCourant & "\" & _ sFichierVBTxtFndMotsCles & sExtDoc If Not bFichierAccessible(sCheminTxt, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False If Not bFichierAccessible(sCheminDoc, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False ' 09/06/2019 Dim sCheminExclusions$ = m_sCheminDossierCourant & "\" & sFichierVBTxtFndAlphab & "_Exclusions.txt" Dim sCheminInclusions$ = m_sCheminDossierCourant & "\" & sFichierVBTxtFndAlphab & "_Inclusions.txt" If Not bFichierAccessible(sCheminExclusions, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False If Not bFichierAccessible(sCheminInclusions, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False Dim bExclusions As Boolean = False Dim hsExcl As HashSet(Of String) = Nothing If bFichierExiste(sCheminExclusions) Then Dim asExcl = asLireFichier(sCheminExclusions, bLectureSeule:=True) ' bUnicodeUTF8:=True) Dim lstExcl = asExcl.ToList If Not m_bIndexerAccents Then lstExcl = ListToListSansAccent(lstExcl) If Not bListToHashSet(lstExcl, hsExcl, bPromptErr:=True) Then Return False If hsExcl.Count > 0 Then bExclusions = True End If Dim bInclusions As Boolean = False Dim hsIncl As HashSet(Of String) = Nothing If bFichierExiste(sCheminInclusions) Then Dim asIncl = asLireFichier(sCheminInclusions, bLectureSeule:=True) ', bUnicodeUTF8:=True) Dim lstIncl = asIncl.ToList If Not m_bIndexerAccents Then lstIncl = ListToListSansAccent(lstIncl) If Not bListToHashSet(lstIncl, hsIncl, bPromptErr:=True) Then Return False If hsIncl.Count > 0 Then bInclusions = True End If m_bInterrompre = False Dim sb As New StringBuilder Sablier() Dim oMot As clsMot Dim sMotGlossaire$ Dim lNumMotIndexe, lNbMotsIndexes As Integer lNbMotsIndexes = Me.m_htMots.Count() lNumMotIndexe = 0 Dim iNbOccEffectives% Dim sCleDocPhrase$, sListeRef$, sMemCleDocPhrase$ Dim i, lFin As Integer Dim sl As New SortedList(CaseInsensitiveComparer.Default) Dim de As DictionaryEntry Dim lMaxOcc%, sMaxFreq$, iLenMaxFreq% Dim sFormatOcc$ = "" If bTriFreq Then AfficherMessage("Recherche du nombre d'occurrence max. pour la présentation...") ' Recherche du nbre d'occ max pour le format de présentation : nbre de 0 For Each de In Me.m_htMots oMot = DirectCast(de.Value, clsMot) If Not bMotsDico AndAlso bMotDico(oMot.sMot) Then Continue For If oMot.iNbOccurrences > lMaxOcc Then lMaxOcc = oMot.iNbOccurrences Next de sMaxFreq = CStr(lMaxOcc) iLenMaxFreq = sMaxFreq.Length For i = 0 To iLenMaxFreq - 1 sFormatOcc &= "0" Next i 'sFormatOcc = VB6.String(iLenMaxFreq, "0") End If ' Projet Complexifieur : fabriquer des mots en les dérivant avec des postfixes : ' Logiciel de complexificationnage du langage (ou jargonasification) ' Complexe -> Complexité -> Complexification -> Complexificationnage -> Complexificationnement... ' Rater -> Ratage -> Rature... Dim asComplexifieurs$(7) If bTestComplexifieur Then ' iComplexifieurMinRecherche iComplexifieurMaxRecherche asComplexifieurs(3) = Config.sComplexifieurs3 asComplexifieurs(4) = Config.sComplexifieurs4 asComplexifieurs(5) = Config.sComplexifieurs5 'asComplexifieurs(6) = Config.sComplexifieurs6 'asComplexifieurs(7) = Config.sComplexifieurs7 If Not m_bIndexerAccents Then asComplexifieurs(3) = sEnleverAccents(Config.sComplexifieurs3) asComplexifieurs(4) = sEnleverAccents(Config.sComplexifieurs4) asComplexifieurs(5) = sEnleverAccents(Config.sComplexifieurs5) End If End If Dim iFreqMin% = Me.m_htMots.Count \ 100 Dim bBiGramme As Boolean = False If sTypeIndex = sIndexNGrammes Then bBiGramme = True Dim htBiG As New Hashtable 'Dim oBG As clsBiGramme For Each de In Me.m_htMots oMot = DirectCast(de.Value, clsMot) 'If oMot.sMot = "temps" Then Debug.WriteLine("!") If Not bMotsDico AndAlso bMotDico(oMot.sMot) Then If Not (bInclusions AndAlso hsIncl.Contains(oMot.sMot)) Then Continue For ' 09/06/2019 'Debug.WriteLine("!") 'Continue For End If Dim sCleMot$ = DirectCast(de.Key, String) If m_bIndexerAccents Then ' Conserver les accents sCleMot = sCleMot.ToLower Else ' Note : les accents sont déjà rétirés ici de toutes façons : pas besoin ' Enlever les accents comme pour la liste des mots courants sCleMot = sEnleverAccents(sCleMot) End If If bExclusions AndAlso hsExcl.Contains(sCleMot) Then Continue For ' 09/06/2019 If Not bMotsCourants AndAlso InStr(sMotsCourants, " " & sCleMot & " ") > 0 Then If Not (bInclusions AndAlso hsIncl.Contains(sCleMot)) Then Continue For ' 09/06/2019 'Debug.WriteLine("!") 'Continue For End If If bBiGramme Then ' Test bigrammes Dim sMotBrut$ = DirectCast(de.Key, String) TestBiGrammesP1(htBiG, sMotBrut) GoTo MotSuivant End If If bMotsCles Then If InStr(sMotsCourants, " " & sCleMot & " ") > 0 Then GoTo MotSuivant End If If oMot.iNbOccurrences < iFreqMin Then GoTo MotSuivant End If End If lNumMotIndexe += 1 If lNumMotIndexe Mod iModuloAvanvementLent = 0 Or _ lNumMotIndexe = lNbMotsIndexes Or lNumMotIndexe = 1 Then AfficherMessage("Création du document index en cours : " & _ lNumMotIndexe & " / " & lNbMotsIndexes) If m_bInterrompre Then Exit For End If sListeRef = "" ' S'il n'y a qu'un seul document indexé, inutile d'indiquer toujours ' la même référence à ce document If iNbDocIndexes = 1 Then GoTo Suite lFin = oMot.iNbPhrases If lFin > iNbOccurencesMaxRecherchees Then GoTo Suite sMemCleDocPhrase = "" iNbOccEffectives = 0 Dim iMemNumPhrase% = -1 For i = 1 To lFin Dim iNumPhrase% = oMot.iLireNumPhrase(i) If iNumPhrase = iMemNumPhrase Then Continue For iMemNumPhrase = iNumPhrase Dim sCodeChapitre$ = "" sCleDocPhrase = sLireCleDocPhrase(iNumPhrase, sCodeChapitre) If sCleDocPhrase = sMemCleDocPhrase Then Continue For sMemCleDocPhrase = sCleDocPhrase Dim sCodeDoc$ = sLireCodeDoc(sCleDocPhrase) If m_bAfficherChapitreIndex AndAlso sCodeChapitre.Length > 0 Then sCodeDoc &= ":" & sCodeChapitre End If iNbOccEffectives += 1 If iNbOccEffectives > iNbOccurrencesMaxListe Then _ sListeRef &= ", ..." : Exit For If i = 1 Then sListeRef = sCodeDoc Else sListeRef &= ", " & sCodeDoc End If Next i Suite: Dim sCle$ If bTriFreq Then ' Tri fréquentiel : on met le nombre d'occurence du mot en premier If bMotsSeulsDocIndex Then sMotGlossaire = oMot.sMot Else If sListeRef <> "" Then sListeRef = " (" & sListeRef & ")" sMotGlossaire = oMot.iNbOccurrences & " : " & oMot.sMot & sListeRef End If ' Ne peut pas marcher avec une SortedList car la clé n'est pas unique ! sCle = Format(oMot.iNbOccurrences, sFormatOcc) & " : " & oMot.sMot & sListeRef Else ' Tri alphabétique : on met le mot en premier If bMotsSeulsDocIndex Then sMotGlossaire = oMot.sMot Else If sListeRef <> "" Then sListeRef = " : " & sListeRef sMotGlossaire = oMot.sMot & " (" & oMot.iNbOccurrences & sListeRef & ")" End If sCle = oMot.sMot End If If bTestComplexifieur Then ' Sélectionner les mots dérivés à partir d'un mot plus simple ' en examinant la fin des mots Dim bMotDerive As Boolean bMotDerive = False Dim sMot$ = oMot.sMot For i = iComplexifieurMinRecherche To iComplexifieurMaxRecherche If sMot.Length > i Then Dim sFinMot$ = Right$(sMot, i) ' Les mots accentués ne sont pas distingués If Not m_bIndexerAccents Then sFinMot = sEnleverAccents(sFinMot) If InStr(asComplexifieurs(i), " " & sFinMot & " ") > 0 Then _ bMotDerive = True : Exit For End If Next i If Not bMotDerive Then GoTo MotSuivant End If If Not bNumeriques Then ' Exclusion des numériques If IsNumeric(sCle) Then Continue For End If 'Try If Not sl.Contains(sCle) Then sl.Add(sCle, sMotGlossaire) Else 'Catch ' S'il y a une erreur, c'est que HashTable est capable de distinguer ' Coeur de cœur, mais pas SortedList, car il n'y a pas d'équivalent de ' CaseInsensitiveHashCodeProvider.Default pour SortedList End If 'End Try MotSuivant: Next de 'oMot If bBiGramme Then TestBiGrammesP2(htBiG, sb, sl) GoTo Fin0 End If Dim sLigne$ Dim iNbMots% = sl.Count If bTriFreq Then For i = iNbMots - 1 To 0 Step -1 If bMotsCles And i < iNbMots - iMaxMotsCles Then Exit For sLigne = DirectCast(sl.GetByIndex(i), String) ' C'est Word qui ajoute des sauts de ligne inopinés If bMotsCles Or bMotsSeulsDocIndex Then sb.Append(sLigne.ToLower & " ") Else sb.Append(sLigne).Append(vbCrLf) End If Next i Else For Each de In sl sLigne = DirectCast(de.Value, String) sb.Append(sLigne).Append(vbCrLf) Next de End If Fin0: Static bWord As Boolean = True Dim iEncodage% = iCodePageWindowsLatin1252 If m_bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 If Not bEcrireFichier(sCheminTxt, sb, iEncodage:=iEncodage) Then _ Sablier(bDesactiver:=True) : Return False ' Si Word n'est pas installé, ne plus essayer de l'ouvrir If Not bCreerDocWord OrElse Not bWord Then GoTo Fin AfficherMessage("Ouverture de Microsoft Word...") If bCreerDocIndex2(sCheminTxt, sCheminDoc, sTitre, sExplication, lNbMotsIndexes, _ Me.m_colDocs, m_bInterrompre, bWord, m_bOptionTexteUnicode, sCodeLangIndex) Then AfficherMessage("Création du document index terminée.") If bProposerOuvrir Then ProposerOuvrirFichier(sCheminDoc) End If Fin: Sablier(bDesactiver:=True) If Not bWord AndAlso bProposerOuvrir Then ProposerOuvrirFichier(sCheminTxt) sCheminFinal = sCheminTxt Return True End Function Private Function ListToListSansAccent(lst As List(Of String)) As List(Of String) Dim lstDest As New List(Of String) For Each sMot In lst lstDest.Add(sEnleverAccents(sMot)) Next Return lstDest End Function Private Sub TestBiGrammesP1(htBiG As Hashtable, sMotBrut$) ' Test bigrammes Dim oBG As clsBiGramme sMotBrut = sEnleverAccents(sMotBrut) Dim j% Dim iLen% = sMotBrut.Length Dim iFin% = 2 iFin = 3 ' Trigrammes For j = 0 To iLen - iFin Dim sCar1$ = sMotBrut.Chars(j) Dim sCar2$ = sMotBrut.Chars(j + 1) Dim sCar3$ = sMotBrut.Chars(j + 2) If Not Char.IsLetter(sCar1.Chars(0)) Or _ Not Char.IsLetter(sCar2.Chars(0)) Or _ Not Char.IsLetter(sCar3.Chars(0)) Then GoTo CarSuiv End If Dim sBiGramme$ = sCar1 & sCar2 & sCar3 If htBiG.ContainsKey(sBiGramme) Then oBG = CType(htBiG(sBiGramme), clsBiGramme) oBG.iNbOccurences += 1 Else oBG = New clsBiGramme oBG.sBiGramme = sBiGramme oBG.iNbOccurences = 1 htBiG.Add(sBiGramme, oBG) End If CarSuiv: Next j End Sub Private Sub TestBiGrammesP2(htBiG As Hashtable, sb As StringBuilder, sl As SortedList) Dim oBG As clsBiGramme Dim sFormatOcc = "0.000%" Dim lOccMax& = 0 Dim lOccTot& = 0 For Each de As DictionaryEntry In htBiG oBG = DirectCast(de.Value, clsBiGramme) lOccTot += oBG.iNbOccurences If oBG.iNbOccurences > lOccMax Then lOccMax = oBG.iNbOccurences Next de For Each de As DictionaryEntry In htBiG oBG = DirectCast(de.Value, clsBiGramme) Dim rFreqTot# = 100 If lOccTot <> 0 Then rFreqTot = oBG.iNbOccurences / lOccTot ' 05/05/2018 Dim sFreq$ = Format(rFreqTot, sFormatOcc) Dim sBG$ = sFreq & " : " & oBG.sBiGramme Dim sCle$ = sFreq & " : " & " : " & oBG.sBiGramme Try sl.Add(sCle, sBG) Catch End Try Next de Dim iNbBG% = sl.Count For i = iNbBG - 1 To 0 Step -1 Dim sLigne0$ = DirectCast(sl.GetByIndex(i), String) sb.Append(sLigne0).Append(vbCrLf) Next i End Sub Private Sub RegenererDocs() ' Régénérer complètement les documents indexés ' (seuls les lignes vides sont supprimées) Dim sCheminTxt$ = m_sCheminDossierCourant & "\" & _ sFichierVBTxtFndTout & sExtTxt Dim sb As New StringBuilder Sablier() ' Utiliser le format de présentation en français, ' en utilisant les préférences de l'utilisateur le cas échéant Dim nfi As System.Globalization.NumberFormatInfo = _ New System.Globalization.CultureInfo("fr-FR", useUserOverride:=True).NumberFormat nfi.NumberDecimalDigits = 0 ' Afficher des nombres entiers, sans virgule sb.Append("Nombre de mots indexés : " & _ Me.iNbMotsG.ToString("N", nfi)).Append(vbCrLf) sb.Append("Nombre de mots distincts indexés : " & _ Me.m_htMots.Count().ToString("N", nfi)).Append(vbCrLf) sb.Append("Nombre de phrases indexées : " & _ m_colPhrases.Count().ToString("N", nfi)).Append(vbCrLf) sb.Append("Nombre de paragraphes indexés : " & _ Me.iNbParagG.ToString("N", nfi)).Append(vbCrLf) If Me.tsDiffTps.Milliseconds <> 0 Then _ sb.Append("Temps d'indexation : " & tsDiffTps.ToString).Append(vbCrLf) sb.Append(vbCrLf) sb.Append("Liste des documents indexés (" & Me.m_colDocs.Count() & ") :").Append(vbCrLf) Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs sb.Append(oDoc.sChemin & " (" & oDoc.sCodeDoc & ")").Append(vbCrLf) Next oDoc If m_bIndexerChapitre Then sb.AppendLine(vbCrLf & "Liste des chapitres :") sb.Append(m_sbChapitres) ' Identique à m_sbChapitres : 'For Each oDoc In Me.m_colDocs ' sb.AppendLine(vbCrLf & oDoc.sChemin & " (" & oDoc.sCodeDoc & ") :") ' For Each chapitre As clsChapitre In oDoc.colChapitres ' sb.AppendLine(chapitre.sCodeChapitre & " : " & chapitre.sChapitre) ' Next chapitre 'Next oDoc End If sb.Append(vbCrLf) sb.Append("Liste des phrases indexées :").Append(vbCrLf) Dim iMemNumParag% = 0 For i = 1 To Me.iNbPhrasesG ' Parcours de toutes les phrases Dim oPhrase As clsPhrase = DirectCast(m_colPhrases.Item(i - 1), clsPhrase) Dim oPhraseSuiv As clsPhrase = oPhrase If i < Me.iNbPhrasesG Then _ oPhraseSuiv = DirectCast(m_colPhrases.Item(i), clsPhrase) If i = 1 Then sb.Append(sInfoDoc(oPhrase)) If oPhrase.iNumParagrapheL <> iMemNumParag And _ oPhrase.iNumParagrapheL = 1 Then If bExporterToutAvecNumeros Then sb.Append(sInfoParag(oPhrase)) iMemNumParag = oPhrase.iNumParagrapheL End If sb.Append(oPhrase.sPhrase) If oPhrase.iNumParagrapheG <> oPhraseSuiv.iNumParagrapheG Then sb.Append(vbCrLf) If oPhraseSuiv.sCleDoc <> oPhrase.sCleDoc Then sb.Append(vbCrLf).Append(vbCrLf) sb.Append(sInfoDoc(oPhraseSuiv)) End If If oPhraseSuiv.iNumParagrapheL <> iMemNumParag And _ oPhraseSuiv.iNumParagrapheL <> oPhrase.iNumParagrapheL Then If bExporterToutAvecNumeros Then sb.Append(sInfoParag(oPhraseSuiv)) iMemNumParag = oPhraseSuiv.iNumParagrapheL End If Next i sb.Append(vbCrLf) If Not bEcrireFichier(sCheminTxt, sb) Then Sablier(bDesactiver:=True) : Exit Sub Sablier(bDesactiver:=True) ProposerOuvrirFichier(sCheminTxt) End Sub Private Function sInfoDoc$(oPhrase As clsPhrase) Dim sCleDoc$ = oPhrase.sCleDoc Dim sCodeDoc$ = sLireCodeDoc(sCleDoc) ' 03/01/2010 Désactivé 'If sCodeDoc <> sCleDoc Then sCleDoc &= " : " & sCodeDoc Dim sCleAffichee$ = sCleDoc If sCodeDoc <> sCleDoc Then sCleAffichee = sCleDoc & " : " & sCodeDoc ' 03/01/2010 Lors de la 1ère indexation, la clé du document associée aux phrases ' est tjrs "Doc n°x" : il le reste ensuite Dim sChemin$ = "" If Me.m_colDocs.Contains(sCleDoc) Then sChemin = DirectCast(Me.m_colDocs(sCleDoc), clsDoc).sChemin & " " sCleAffichee = DirectCast(Me.m_colDocs(sCleDoc), clsDoc).sCodeDoc End If 'sInfoDoc = "Document : " & sChemin & "(" & sCleDoc & ")" & vbCrLf & vbCrLf sInfoDoc = "Document : " & sChemin & "(" & sCleAffichee & ")" & vbCrLf & vbCrLf End Function Private Function sInfoParag$(oPhrase As clsPhrase) sInfoParag = _ "§G:" & oPhrase.iNumParagrapheG & _ ", §L:" & oPhrase.iNumParagrapheL & _ ", Ph.G:" & oPhrase.iNumPhraseG & _ " Ph.L:" & oPhrase.iNumPhraseL & " : " End Function Public Sub AnalyseAccents(sCodeLangIndex$, sCodesLanguesIndex$) ' D'abord vérifier que WinMerge est bien installé Dim sCheminWinMerge$ = "" If Not bLireCleBRWinMerge(sCheminWinMerge$) Then Exit Sub ' Vérifier si le dictionnaire est présent Dim sCheminDico0 = Application.StartupPath & sCheminDico & "_" & _ sCodeLangIndex & sExtTxt If Not bFichierExiste(sCheminDico0) Then MsgBox("Le dictionnaire est introuvable :" & vbLf & _ sCheminDico0, MsgBoxStyle.Exclamation) Exit Sub End If ' Ensuite indexer à nouveau tous les documents avec les accents Dim bMemAccent = m_bIndexerAccents m_bIndexerAccents = True Dim bEchec As Boolean = False ReinitDicoAccentOuPas() Dim iNumFichier% = 0 For Each oDoc As clsDoc In Me.m_colDocs iNumFichier += 1 Dim sNumFichier$ = iNumFichier.ToString If Not bIndexerDocumentInterne(oDoc.sChemin, sNumFichier, oDoc.sCodeDoc) Then _ bEchec = True : GoTo Fin Next oDoc ' Ensuite créer l'index des mots hors dico avec accent Dim sCheminDestAccent$ = "" CreerDocIndex(sIndexAlpha, _ bMotsDico:=False, bMotsCourants:=False, sCheminDico0:=sCheminDico0, _ sCodeLangIndex:=sCodeLangIndex, _ bMotsSeulsDocIndex0:=True, iMaxMotsCles:=0, bNumeriques:=False, sCodesLanguesIndex:=sCodesLanguesIndex, bCreerDocWord:=False, bProposerOuvrir:=False, sCheminFinal:=sCheminDestAccent) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminDestAccent) Dim sFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminDestAccent) Dim sFichierDest$ = sFichier & "_Accent.txt" '& IO.Path.GetExtension(sCheminDestAccent) Dim sCheminFinalAccent$ = sDossier & "\" & sFichierDest If Not bRenommerFichier(sCheminDestAccent, sCheminFinalAccent) Then _ bEchec = True : GoTo Fin ' Ensuite indexer à nouveau tous les documents sans les accents m_bIndexerAccents = False ReinitDicoAccentOuPas() iNumFichier = 0 For Each oDoc As clsDoc In Me.m_colDocs iNumFichier += 1 Dim sNumFichier$ = iNumFichier.ToString If Not bIndexerDocumentInterne(oDoc.sChemin, sNumFichier, oDoc.sCodeDoc) Then _ bEchec = True : GoTo Fin Next oDoc ' Ensuite créer l'index des mots hors dico sans accent Dim sCheminDestSansAccent$ = "" CreerDocIndex(sIndexAlpha, _ bMotsDico:=False, bMotsCourants:=False, sCheminDico0:=sCheminDico0, _ sCodeLangIndex:=sCodeLangIndex, _ bMotsSeulsDocIndex0:=True, iMaxMotsCles:=0, bNumeriques:=False, sCodesLanguesIndex:=sCodesLanguesIndex, bCreerDocWord:=False, bProposerOuvrir:=False, sCheminFinal:=sCheminDestSansAccent) Dim sFichier2$ = IO.Path.GetFileNameWithoutExtension(sCheminDestSansAccent) Dim sFichierDest2$ = sFichier2 & "_SansAccent.txt" '& IO.Path.GetExtension(sCheminDestSansAccent) Dim sCheminFinalSansAccent$ = sDossier & "\" & sFichierDest2 If Not bRenommerFichier(sCheminDestAccent, sCheminFinalSansAccent) Then _ bEchec = True : GoTo Fin ' Ouvrir WinMerge avec ces 2 index avec et sans accent Const sGm$ = """" Dim sCmd$ = sGm & sCheminFinalSansAccent & sGm & " " & sGm & sCheminFinalAccent & sGm Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminWinMerge) p.StartInfo.Arguments = sCmd p.Start() Fin: m_bIndexerAccents = bMemAccent If bEchec Then AfficherMessage("Erreur !") Else AfficherMessage(sMsgOperationTerminee) End If End Sub Private Function bLireCleBRWinMerge(ByRef sCheminWinMerge$) As Boolean sCheminWinMerge = "" If Not bCleRegistreCUExiste("SOFTWARE\Thingamahoochie\WinMerge", _ "Executable", sCheminWinMerge) Then MsgBox("L'utilitaire WinMerge n'est pas installé (clé de registre non trouvée)", MsgBoxStyle.Critical, sTitreMsg & " - Analyse des accents") Return False End If ' Par défaut : "C:\Program Files\WinMerge\WinMergeU.exe" If sCheminWinMerge.Length = 0 Then Return False If Not bFichierExiste(sCheminWinMerge, bPrompt:=True) Then Return False Return True End Function #End Region End Class modConfig.vb ' Fichier modConfig.vb : Module de configuration ' ---------------------- Module Config Public Const bSupprimerEspInsec As Boolean = False ' 06/03/2016 Faire une option ? ' 05/05/2018 Nouveau dictionnaire basé sur frgut + DELA + LibreOffice : ' DELA : http://infolingu.univ-mlv.fr/DonneesLinguistiques/Dictionnaires/telechargement.html ' LibreOffice : www.dicollecte.org 'Public Const sCheminDicoV1Fr$ = "\Dico\liste.de.mots.francais.frgut.txt" Public Const sCheminDico$ = "\Dico\Dico" '_Fr.txt" ' Trop long dans l'explorateur ! 'Public Const sURLDico$ = "http://www.pallier.org/ressources/dicofr/liste.de.mots.francais.frgut.txt" ' 800 Ko : ok ! 'Public Const sURLDicoFr$ = "http://patrice.dargenton.free.fr/CodesSources/VBTextFinder/DicoVBTF.zip" ' 05/05/2018 Public Const sURLDicoFr$ = "http://patrice.dargenton.free.fr/CodesSources/VBTextFinder/Dico_Fr.zip" ' AGID is an Automatically Generated Inflection Database from an insanely large word list. ' http://downloads.sourceforge.net/wordlist/agid-4.zip Public Const sURLDicoEn$ = "http://patrice.dargenton.free.fr/CodesSources/VBTextFinder/Dico_En.zip" ' Ce sont les mêmes dico. pour l'instant Public Const sURLDicoUk$ = "http://patrice.dargenton.free.fr/CodesSources/VBTextFinder/Dico_Uk.zip" Public Const sURLDicoUs$ = "http://patrice.dargenton.free.fr/CodesSources/VBTextFinder/Dico_Us.zip" Public Const bCompatVB6RechercheAussiAvecAccents As Boolean = True ' sMotsCourants ne contient pas les accents : ' les mots clés ne fonctionneront plus si on indexe les accents ' Si Unicode alors conserver les accents et tous les caractères exotiques 'Public bIndexerAccents As Boolean = False ' Ignorer les accents 'Public Const bIndexerAccents As Boolean = False ' Ignorer les accents 'Public Const bIndexerAccents As Boolean = True ' Distinguer les accents ' Exporter tous les documents avec les n° de § et de ph. global et local ' (pour vérifier que l'affichage des n° fonctionne bien) Public Const bExporterToutAvecNumeros As Boolean = False ' Nombre de références maximum indiquées pour chaque mot du document index Public Const iNbOccurrencesMaxListe% = 12 ' Nombre de références maximum recherchées (pour les mots trop fréquents) Public Const iNbOccurencesMaxRecherchees% = 100 Public Const iNbCarChapitreMax% = 8 '10 '5 ' Si le fichier externe est présent alors il remplace la liste codée en dur Public Const sCheminSeparateursPhrase$ = "\Dico\SeparateursPhrase.txt" Public Const sCheminSeparateursMot$ = "\Dico\SeparateursMot.txt" Public Const sListeSeparateursPhrase$ = ".:?!;|¡¿" Public Const sListeSeparateursMot$ = " ,&~'`´‘’()[]{}<>–-+±*/¦\@=°%#$€£§…" Public Const sCheminChapitrage$ = "\Dico\Chapitrage.txt" Public Const sCheminChapitrageExcel$ = "\Dico\ChapitrageExcel.txt" Public Const sCheminChapitrageAccess$ = "\Dico\ChapitrageAccess.txt" Public Const sChapitrageDef$ = "Chapitre;Chap;Livre;Livre" Public Const sChapitrageXLDef$ = "Feuille Excel n°;Feuil." Public Const sChapitrageMdbDef$ = _ "Structure Table Access n°;Struc.Table;" & _ "Table Access n°;Table;" & _ "Module VBA Access n°;ModVBA;" & _ "Formulaire VBA Access n°;FrmVBA;" & _ "Etat VBA Access n°;EtatVBA;" & _ "Définition Requête Access n°;DefRq;" & _ "Requête Access n°;Rq;" & _ "Requêtes systèmes Access;RqSys" Public Const iMaxMotsClesDef% = 50 ' Si le fichier externe est présent alors il remplace la liste codée en dur ' 28/08/2009 On tient maintenant compte du code langue : Si Fr : MotsCourants_Fr.txt Public Const sCheminMotsCourants$ = "\Dico\MotsCourants" '.txt" Public Const sMotsCourantsFr$ = " de la le l et les est à dans il que nous en des qui du d un une se ce qu ne pour a pas avec au par vous je n s c sont on ils sur ces tout plus ou cette son mais même si moi elle notre comme y tous lui être leur ses ont sa sans alors très peut aux celui ainsi où toutes mon ceux me bien dit fait tu grand doit deux toute quand cela nos était car j leurs autre lorsque aussi faut etc avons toujours donc autres dire grande chose jusqu là devons entre etre temps après cet jamais m faire parce votre ai chaque mêmes vers beaucoup rien été avoir elles fois avait eux maintenant seulement encore ni trouve sous fut sommes jour quelque non mes suis dont contre sera soit afin peu avant ma ceci ci moment point état tant devant ici t toi lorsqu or veut déjà ton aucun celle vos avez êtes selon " ' Séparateurs de mot supplémentaires : ne figurent pas dans la première liste Public Const iCodeASCIITabulation% = 9 ' https://murviel-info.com/specialchars.php Public Const iCodeASCIIEspaceInsecable% = 160 ' Non-breaking space &nbsp; ' 13/07/2019 Rétabli pour le mode Unicode Public Const iCodeUTF16EspaceInsecable% = 8201 ' Alt+8201 espace fine &thinsp; ' Cocher l'option Unicode pour pouvoir utiliser ces car.: Public Const iCodeUTF16EspaceFineInsecable% = 8239 ' Alt+8239 = 0x202F = espace fine insécable 'Public Const iCodeASCIIEspaceInsecable4% = 8194 ' espace demi-cadratin &ensp; 'Public Const iCodeASCIIEspaceInsecable5% = 8195 ' espace cadratin &emsp; 'Public Const iCodeASCIIEspaceInsecable6% = 255 ' Public Const iCodeASCIIGuillemet% = 34 ' " Public Const iCodeASCIIQuote% = 39 ' Public Const iCodeASCIIGuillemetOuvrant% = 171 ' « Public Const iCodeASCIIGuillemetFermant% = 187 ' » Public Const iCodeASCIIGuillemetOuvrant2% = 145 ' ‘ Public Const iCodeASCIIGuillemetFermant2% = 146 ' ’ Public Const iCodeASCIIGuillemetOuvrant3% = 147 ' “ Public Const iCodeASCIIGuillemetFermant3% = 148 ' ” Public Const iCodeASCIIGuillemetOuvrant4% = 96 ' ` Public Const iCodeASCIIGuillemetFermant4% = 180 ' ´ Public Const iCodeASCIIGuillemetOuvrant5% = 139 ' ‹ Public Const iCodeASCIIGuillemetFermant5% = 155 ' › Public Const sGm$ = Chr(iCodeASCIIGuillemet) Public Const iModuloAvanvementTresLent% = 10000 Public Const iModuloAvanvementLent% = 1000 Public Const iModuloAvanvement% = 100 ' Affichage périodique de l'avancement Public Const iModuloAvanvementRapide% = 10 ' Faire une sauvegarde de sécurité à chaque indexation d'un nouveau document ' sFichierVBTxtFndTmp = "VBTxtFnd.tmp" Public Const bSauvegardeSecurite As Boolean = False Public Const bTestComplexifieur As Boolean = False Public Const iComplexifieurMinRecherche% = 3 Public Const iComplexifieurMaxRecherche% = 5 Public Const sComplexifieurs3$ = " ure oir age " Public Const sComplexifieurs4$ = " cité isme naire ogie ance ible tion " Public Const sComplexifieurs5$ = " ilité iaire ateur sseur ement " 'logie tible 'Public Const sComplexifieurs6$ = " ssible " 'ssance nement 'Public Const sComplexifieurs7$ = " ssement " 'Public Const iNbCouleursHtml% = 5 'http://htmlhelp.com/cgi-bin/color.cgi Public Const sCouleursHtmlDef$ = "yellow;lightgreen;lightblue;silver;turquoise" End Module modStruct.vb Friend Class clsDoc ' clsDoc : classe pour indexer la liste des documents indexés ' Clé de la collection : code mnémonique du document indexé ' (ce code est précisé dans les résultats de recherche) Public sCle$ ' sCodeDoc Public sCodeDoc$ ' Clé éditée dans le fichier ini (nouveau !) Public sChemin$ ' Chemin du document indexé Public bTxtUnicode As Boolean ' Encodage unicode ? sinon encodage par défaut 26/01/2019 ' Nombre de mots indexés du document indexé (pas encore utilisé) 'Public lNbMotsIndexes& Public colChapitres As New Collection 'Public colChapitres As Collection End Class Friend Class clsChapitre ' clsChapitre : classe pour indexer la liste des chapitres des documents indexés ' Clé de la collection : code mnémonique du chapitre ' (ce code est précisé dans les résultats de recherche) Public sCle$ ' CleDoc:CodeChapitre Public sCodeChapitre$ Public sCleDoc$ ' Clé d'origine du document : Doc n°1, ... Public sCodeDoc$ ' Clé éditée du document dans le fichier ini Public sChapitre$ ' Chemin du document indexé End Class Friend Class clsPhrase ' clsPhrase : classe pour indexer les phrases Public sClePhrase$ ' Clé de la collection : numéro de la phrase global Public iNumPhraseG% ' Numéro de la phrase global des documents indexés Public iNumPhraseL% ' Numéro de la phrase local au document indexé Public sPhrase$ ' Phrase stockée en intégralité Public sCleDoc$ ' Code mnémonique du document dans lequel figure la phrase Public sCodeChapitre$ ' 19/06/2010 Public iNumParagrapheL% ' Numéro du paragraphe local dans lequel figure la phrase Public iNumParagrapheG% ' Numéro du paragraphe global dans lequel figure la phrase End Class Friend Class clsMot ' clsMot : classe pour indexer les mots ' Clé de la collection : le mot lui-même ' on est obligé de conserver la clé en tant que membre publique de la classe ' car il n'existe aucun moyen (en VB6) d'y accéder, par exemple dans une boucle For Each ' (sauf en bidouillant avec des pointeurs) Public sMot$ Public iNbOccurrences% ' Nombre d'occurrences du mot 'Public lNbPhrases% ' Nombre de phrases dans lesquelles ce mot figure 'Private m_alNumPhrases%() ' Tableau des n° de phrase dans lesquelles ce mot figure ' Si le mot figure plusieurs fois dans la même phrase, ' on duplique quand même le n° de phrase Public aiNumPhrase As New ArrayList Public Function iLireNumPhrase%(ByRef iIndex%) ' L'index commence à 1 vu de l'extérieur de la classe ' (phrase n°1 = 1ère phrase) mais commence à 0 en interne 'iLireNumPhrase = m_alNumPhrases(lIndex - 1) iLireNumPhrase = DirectCast(Me.aiNumPhrase.Item(iIndex - 1), Integer) End Function Public Function iNbPhrases%() iNbPhrases = Me.aiNumPhrase.Count End Function Public Sub RedimPhrases(iNbPhrases0%) 'lNbPhrases = lNbPhrases0 'ReDim m_alNumPhrases(lNbPhrases - 1) Me.aiNumPhrase = New ArrayList(iNbPhrases0) End Sub Public Sub AjouterNumPhrase3(iNumPhrases%) ' Ajouter une référence de phrase contenant ce mot Me.aiNumPhrase.Add(iNumPhrases) End Sub End Class Friend Class clsBiGramme ' clsBiGramme : classe pour comptabiliser la fréquence des bigrammes ' Clé de la collection : le bigramme Public sBiGramme$ Public iNbOccurences% ' Nombre d'occurrences du bigramme End Class modUtilVBTF.vb ' Fichier modUtilVBTF.vb : Module utilitaire pour VBTextFinder ' ---------------------- Imports System.Text ' Pour StringBuilder Imports System.Text.Encoding ' Pour GetEncoding Imports System.Runtime.CompilerServices ' Pour l'attribut <Extension()> Module modUtilVBTF ' Longueur max. d'une chaîne dans un contrôle Public Const iMaxLongChaine0 As Short = 32767 '32000 En VB6, 7 ?, 8 ? mais plus 9 ! 'Public Const iMaxLongChaine% = iMaxLongChaine0 ' 01/05/2010 (147 483 647 au lieu de 32767) Public Const iMaxLongChaine% = Int32.MaxValue Public Function bEcrireChaine(bw As IO.BinaryWriter, sChaine$) As Boolean ' Ecrire une chaîne de longueur variable dans un fichier binaire ' on utilise ByRef pour éviter de réallouer la chaîne en RAM Dim iLongChaine As Short iLongChaine = CShort(sChaine.Length) bw.Write(iLongChaine) bw.Write(sChaine.ToCharArray()) bEcrireChaine = True End Function Public Function bLireChaine(br As IO.BinaryReader, ByRef sChaine$) As Boolean ' Lire une chaîne de longueur variable dans un fichier binaire ' pour cela, il faut d'abord sauvegarder la longueur de la chaîne Dim iLongChaine As Short ' Int16 ' Lire d'abord la longueur de la chaîne iLongChaine = br.ReadInt16() 'FileGet(iNumFichier, iLongChaine) 'If iLongChaine <= 0 Then Exit Function ' C'est surement une erreur si la chaîne est trop longue If iLongChaine > iMaxLongChaine0 Then Return False End If 'sChaine = Space(iLongChaine) ' = String(iLongChaine, " ") 'sChaine = br.ReadString ' Ne fonctionne pas toujours avec les accents sChaine = br.ReadChars(iLongChaine) If sChaine.Length <> iLongChaine Then Return False End If 'FileGet(iNumFichier, sChaine) Return True End Function Public Function bCarNumerique(cCar As Char) As Boolean ' Vérifier si le car. est numérique (romain ou pas) bCarNumerique = False If Char.IsDigit(cCar) Then bCarNumerique = True Else Dim cCarMaj As Char = Char.ToUpper(cCar) Dim iPosCarRomain% = cCarMaj.ToString.IndexOfAny("IVXLCD".ToCharArray) If iPosCarRomain > -1 Then bCarNumerique = True End If End Function Public Function sRognerDernierCar$(sTexte$, sCar$) Dim sTexte2$ = sTexte.TrimEnd If sTexte2.EndsWith(sCar) Then sRognerDernierCar = Left$(sTexte2, sTexte2.Length - 1) Else sRognerDernierCar = sTexte2 End If End Function <Extension()> _ Public Function IndexOfUppercase%(sTexte$, Optional iDeb% = 0) ' Retourner l'index de la 1ère majuscule trouvée après iDeb, sinon -1 Dim bTrouve As Boolean = False Dim iIdx% = 0 For Each cChar0 In sTexte If iIdx >= iDeb AndAlso Char.IsUpper(cChar0) Then bTrouve = True : Exit For iIdx += 1 Next If Not bTrouve Then Return -1 Return iIdx End Function <Extension()> _ Public Function VBSplit(sTexte$, acSepMot() As Char) As String() ' Découper le texte sTexte en tableau de String, selon les séparateurs indiqués ' (comme la fonction String.Split) Dim ac = sTexte.ToCharArray Dim lst As New List(Of String) Dim sb As New StringBuilder Dim iNbCar% = sTexte.Length Dim iNumCar% = 0 For Each c In ac iNumCar += 1 Dim bSep As Boolean = False For Each cSep In acSepMot If c = cSep Then bSep = True : Exit For Next If bSep Then lst.Add(sb.ToString) If iNumCar = iNbCar Then lst.Add("") sb = New StringBuilder Else sb.Append(c) End If Next If sb.Length > 0 Then lst.Add(sb.ToString) Dim astr = lst.ToArray Return astr End Function End Module modUtilLT.vb ' Fichier modUtilLT.vb : Module de fonctions utilitaires en liaison tardive ' --------------------- Option Strict Off ' Module non strict Module modUtilitairesLiaisonTardive Public Function bConvertirDocEnTxt2(sCheminFichierSelect$, _ sCheminFichierTxt$, sCheminDossierCourant$, _ msgDelegue As clsMsgDelegue, bOptionTexteUnicode As Boolean, _ bVerifierUnicode As Boolean, ByRef bTxtUnicode As Boolean, ByRef bAvertUnicode As Boolean, _ ByRef bInfoTxtNonUnicode As Boolean) As Boolean ' Convertir un fichier .doc ou .html en .txt Dim oWrdH As clsHebWord = Nothing bTxtUnicode = False bAvertUnicode = False bInfoTxtNonUnicode = False Try oWrdH = New clsHebWord(bInterdireAppliAvant:=False) If IsNothing(oWrdH.oWrd) Then Return False Const wdCRLF% = 0 Const wdFormatText% = 2 msgDelegue.AfficherMsg("Ouverture de Microsoft Word...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor oWrdH.oWrd.Visible = False msgDelegue.AfficherMsg("Ouverture du fichier " & _ sCheminFichierSelect & "...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor oWrdH.oWrd.Documents.Open(sCheminFichierSelect) msgDelegue.AfficherMsg("Conversion en .txt du fichier " & _ sCheminFichierSelect & "...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor oWrdH.oWrd.ChangeFileOpenDirectory(sCheminDossierCourant) ' 28/04/2018 Correction du bug "Espace mémoire insuffisant" ' (voir la ligne CharacterUnitFirstLineIndent = 0 plus bas) ' 19/01/2019 Maintenant ce code provoque une autre erreur : désactivation ! Const bSupprSignets As Boolean = False If bSupprSignets Then msgDelegue.AfficherMsg("Suppression des signets du fichier " & _ sCheminFichierSelect & "...") oWrdH.oWrd.ActiveDocument.Bookmarks.ShowHidden = True Dim objBkm As Object = Nothing ' As Bookmark For Each objBkm In oWrdH.oWrd.ActiveDocument.Bookmarks 'Try objBkm.Delete() 'Catch 'ex As Exception '' L'exception System.Runtime.InteropServices.COMException s'est produite '' ErrorCode=-2146822463 '' HResult=-2146822463 '' Message=L'objet a été supprimé. 'Exit For 'End Try Next oWrdH.oWrd.ActiveDocument.Bookmarks.ShowHidden = False End If ' 02/05/2010 Ne pas ajouter d'espace de présentation : ' AddBiDiMarks:=False et supprimer tous les retraits oWrdH.oWrd.Selection.WholeStory() With oWrdH.oWrd.Selection.ParagraphFormat ' 18/05/2014 Si le document est en mode Plan alors repasser en mode affichage Page Const wdMasterView% = 5 ' Membre de Word.WdViewType Const wdPrintView% = 3 Const wdPaneNone% = 0 ' Membre de Word.WdSpecialPane If oWrdH.oWrd.ActiveWindow.View.SplitSpecial = wdPaneNone Then If oWrdH.oWrd.ActiveWindow.ActivePane.View.Type = wdMasterView Then oWrdH.oWrd.ActiveWindow.ActivePane.View.Type = wdPrintView End If Else If oWrdH.oWrd.ActiveWindow.View.Type = wdMasterView Then oWrdH.oWrd.ActiveWindow.View.Type = wdPrintView End If End If .SpaceBeforeAuto = False .SpaceAfterAuto = False .FirstLineIndent = 0 'CentimetersToPoints(0) ' Solution trouvée à ce bug : supprimer tous les signets cachés ' (ceux de la table des matières) ' "Microsoft Word" "Espace mémoire insuffisant" "Une fois terminée, cette action ne pourra pas être annulée" Continuer ? ' "Word has insufficient memory" "You will not be able to undo this action once it is completed" "Do you want to continue?" .CharacterUnitFirstLineIndent = 0 End With ' 19/09/2009 Il faut préciser AllowSubstitutions:=False ' sinon des substitutions peuvent avoir lieu par exemple de « en " 'http://msdn.microsoft.com/fr-fr/library/microsoft.office.tools.word.document.saveas%28VS.80%29.aspx ' 15/05/2010 Dim iEncodage% = iCodePageWindowsLatin1252 If bOptionTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 msgDelegue.AfficherMsg("Ecriture du fichier " & sCheminFichierTxt & "...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor ' 02/05/2010 AddBiDiMarks:=False : Ne pas ajouter d'espace de présentation oWrdH.oWrd.ActiveDocument.SaveAs( _ FileName:=sCheminFichierTxt, _ FileFormat:=wdFormatText, _ Encoding:=iEncodage, _ LineEnding:=wdCRLF, _ AllowSubstitutions:=False, _ AddBiDiMarks:=False) ' 23/11/2018 Si l'option Unicode n'est pas activé, tester quand même et comparer Dim sCheminU$ = "" If bVerifierUnicode Then msgDelegue.AfficherMsg("Vérication Unicode...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor sCheminU = sDossierParent(sCheminFichierTxt) & "\" & _ IO.Path.GetFileNameWithoutExtension(sCheminFichierTxt) & "_Utmp00.txt" If Not bOptionTexteUnicode Then oWrdH.oWrd.ActiveDocument.SaveAs( _ FileName:=sCheminU, _ FileFormat:=wdFormatText, _ Encoding:=iEncodageUnicodeUTF8, _ LineEnding:=wdCRLF, _ AllowSubstitutions:=False, _ AddBiDiMarks:=False) Dim sTexteU$ = sLireFichier(sCheminU, bLectureSeule:=True, bUnicodeUTF8:=True) Dim sTexte$ = sLireFichier(sCheminFichierTxt, bLectureSeule:=True) If sTexteU <> sTexte Then bAvertUnicode = True bTxtUnicode = True 'MsgBox("Le texte contient des caractères Unicode et l'option n'est pas activée", _ ' MsgBoxStyle.Exclamation, m_sTitreMsg) End If Else oWrdH.oWrd.ActiveDocument.SaveAs( _ FileName:=sCheminU, _ FileFormat:=wdFormatText, _ Encoding:=iCodePageWindowsLatin1252, _ LineEnding:=wdCRLF, _ AllowSubstitutions:=False, _ AddBiDiMarks:=False) Dim sTexte$ = sLireFichier(sCheminU, bLectureSeule:=True) Dim sTexteU$ = sLireFichier(sCheminFichierTxt, bLectureSeule:=True, bUnicodeUTF8:=True) If sTexteU = sTexte Then bInfoTxtNonUnicode = True 'MsgBox("Le texte ne contient pas de caractères Unicode", _ ' MsgBoxStyle.Exclamation, m_sTitreMsg) Else bTxtUnicode = True End If End If End If msgDelegue.AfficherMsg("Fermeture du fichier " & sCheminFichierTxt & "...") Application.DoEvents() : Cursor.Current = Cursors.WaitCursor oWrdH.oWrd.ActiveDocument.Close() If bVerifierUnicode Then bSupprimerFichier(sCheminU, bPromptErr:=True) sCheminFichierSelect = sCheminFichierTxt msgDelegue.AfficherMsg(sMsgOperationTerminee) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirDocEnTxt2") Return False Finally If Not IsNothing(oWrdH.oWrd) Then 'oWrdH.oWrd.Quit() ' Ne pas sauvegarder les changements s'il y a eu une erreur (document déjà ouvert) oWrdH.oWrd.Quit(SaveChanges:=False) oWrdH.oWrd = Nothing oWrdH.Quitter() oWrdH = Nothing End If End Try End Function End Module clsHebOffice.vb Option Strict Off ' Pour oWkb.Close() ' clsHebOffice : classe pour héberger une application Office (Word, Excel, ...) ' basée sur clsExcelHost, cf. XLDOTNET : ' XLDOTNET : QUITTER EXCEL SANS LAISSER D'INSTANCE EN RAM ' https://codes-sources.commentcamarche.net/source/27541 #Region "Informations" ' D'après : ' ====================================================================================== ' clsExcelHost : Classe pour héberger Excel ' ============ ' Title: EXCEL.EXE Process Killer ' Description: After many weeks of trying to figure out why the EXCEL.EXE Process ' does not want to go away from the Task Manager, I wrote this class that will ensure ' that the correct EXCEL.EXE Process is closed. This is after using Excel.Application ' via Automation from a VB.NET/ASP.NET application. ' This file came from Planet-Source-Code.com... the home millions of lines of source code ' You can view comments on this code/and or vote on it at: ' http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=1998&lngWId=10 ' The author may have retained certain copyrights to this code... ' please observe their request and the law by reviewing all copyright conditions ' at the above URL. ' Author: I.W Coetzer 2004/01/22 ' *Thanks Dan for the process idea. ' Classe commentée et légèrement modifiée par Patrice Dargenton le 05/11/2004 ' *Solution to the EXCEL.EXE Process that does not want to go away from task manager. ' ' ====================================================================================== #End Region #Region "clsHebOffice" Public Class clsHebOffice Public m_oApp As Object = Nothing 'Protected Private m_iIdProcess% = 0 Public m_bAppliDejaOuverte As Boolean = False Public m_bInterdireAppliAvant As Boolean = True Public m_sNomProcess$ = "" Public Sub New(sNomProcess$, sClasseObjet$, _ Optional bInterdireAppliAvant As Boolean = True, _ Optional bReutiliserInstance As Boolean = False) ' Exemple : 'Private Const sClasseObjetWord$ = "Word.Application" 'Private Const sNomProcessWord$ = "Word" 'Private Const sClasseObjetExcel$ = "Excel.Application" 'Private Const sNomProcessExcel$ = "Excel" Me.m_iIdProcess = 0 Me.m_bAppliDejaOuverte = False Me.m_bInterdireAppliAvant = bInterdireAppliAvant Me.m_sNomProcess = sNomProcess Dim sNomProcessMaj$ = sNomProcess.ToUpper ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() Dim j% For j = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(j).ProcessName = sNomProcessMaj Then Me.m_bAppliDejaOuverte = True Exit For End If Next j If bInterdireAppliAvant And Me.m_bAppliDejaOuverte Then Exit Sub ' Créer le processus demandé Try If Me.m_bAppliDejaOuverte And bReutiliserInstance Then ' Pb : on récupère n'importe quelle instance ' il faudrait plutôt conserver l'instance qu'on a créée Me.m_oApp = GetObject(, sClasseObjet) Else Me.m_oApp = CreateObject(sClasseObjet) End If Catch Ex As Exception 'AfficherMsgErreur2(Ex, "clsHebOffice:New", _ ' sNomProcess & " n'est pas installé !") MsgBox(sClasseObjet & " n'est pas installé !" & vbLf & _ Ex.Message, MsgBoxStyle.Critical, _ "Lancement de " & sNomProcess) Me.m_oApp = Nothing Exit Sub End Try ' Liste des processus après le mien : la différence me donnera l'Id du mien Dim aProcessAp() As Process = Process.GetProcesses() Dim i% Dim bMonProcess As Boolean For j = 0 To aProcessAp.GetUpperBound(0) If aProcessAp(j).ProcessName = sNomProcessMaj Then bMonProcess = True ' Parcours des processus avant le mien For i = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(i).ProcessName = sNomProcessMaj Then If aProcessAp(j).Id = aProcessAv(i).Id Then ' S'il existait avant, ce n'était pas le mien bMonProcess = False Exit For End If End If Next i If bMonProcess = True Then ' Maintenant que j'ai son Id, je pourrai le tuer ' cette méthode marche toujours ! Me.m_iIdProcess = aProcessAp(j).Id Exit For End If End If Next j End Sub Public Sub Quitter() If Me.m_iIdProcess = 0 Then Exit Sub If Not bMonInstanceOuverte() Then ' 28/08/2009 L'instance n'est plus ouverte, mais voir s'il faut libérer les variables 'Try ' 27/02/2011 Déjà Try catch dans la fct LibererObjetCom LibererObjetCom(Me.m_oApp) 'Me.m_oApp = Nothing : Déjà fait 'Catch ex As Exception ' Debug.WriteLine(ex) 'End Try Exit Sub End If LibererObjetCom(Me.m_oApp) ' 27/02/2011 ' 27/02/2011 Cette ligne peut echouer si le process est déjà quitté : ' "Un processus ayant l'ID x n'est pas exécuté" 'Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess) Dim monProc As Process = Nothing Try monProc = Process.GetProcessById(Me.m_iIdProcess) Catch 'ex As Exception ' Le processus vient de se terminer, il n'y a plus rien à faire Exit Sub End Try ' Même si l'instance a été fermée, monProc est toujours valide : ' ce test n'est pas suffisant If Not IsNothing(monProc) Then Try ' 15/05/2009 Libérer avant de tuer le processus ' Pour Excel l'objet oXL a déjà été libéré, ' mais il faut aussi libérer m_oApp ? c'est pourtant le même pointeur !? 'LibererObjetCom(Me.m_oApp) 27/02/2011 'Me.m_oApp = Nothing : Déjà fait ' Si l'instance ne nous appartient pas, on ne peut pas la fermer ' mais on ne reçoit aucune exception ! ' 27/02/2011 If Not monProc.HasExited : inutile de tuer alors If Not monProc.HasExited Then monProc.Kill() ' On ne peut pas interroger immédiatement ExitCode, seule solution : ' vérifier si l'appli est toujours ouverte avec l'iIdProcess 'If monProc.ExitCode = -1 Then ' ' MainModule vaut alors {"Accès refusé"} ' Debug.WriteLine("Impossible de fermer " & _ ' Me.m_sNomProcess & " : " & monProc.MainModule.ToString) 'End If Catch ex As Exception Debug.WriteLine(ex) End Try End If End Sub Public Function bMonInstanceOuverte() As Boolean ' Vérifier si l'instance que j'ai utilisée est encore ouverte ' (elle a pu être fermée par l'utilisateur si on l'autorise) If Me.m_iIdProcess = 0 Then Return False ' 28/08/2009 Avec Word cela ne marche pas, car Word déjà quitté ' D'abord on vérifie s'il ne reste plus aucune instance If Not bOuvert(Me.m_sNomProcess) Then Return False Dim monProc As Process Try ' Puis on teste si on peut récupérer l'instance monProc = Process.GetProcessById(Me.m_iIdProcess) Catch ' On ne peut pas : l'instance est déjà fermée ' "Un processus ayant l'ID xxxx n'est pas exécuté." Return False End Try ' Même si l'instance a été fermée, monProc est toujours valide : ' cette fonction n'est pas suffisante 'If IsNothing(monProc) Then Exit Function 'bMonInstanceOuverte = True ' 15/05/2009 Try Return Not monProc.HasExited() Catch 'ex As Exception ' On vient juste de fermer Return False End Try End Function Public Shared Function bOuvert(sNomProcess$) As Boolean ' Vérifier si l'application est déjà ouverte ' (pour le cas où cela poserait problème, faire la vérification au départ) Dim sNomProcessMaj$ = sNomProcess.ToUpper ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() Dim j% For j = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(j).ProcessName = sNomProcessMaj Then Return True Next j Return False End Function Public Shared Sub LibererObjetCom(ByRef oCom As Object) ' ByRef car on fait oCom = Nothing) ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing ' Pour Excel : ' Quit Excel and clean up. ' oBook.Close(false, oMissing, oMissing); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBook); ' oBook = null; ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBooks); ' oBooks = null; ' oExcel.Quit(); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oExcel); ' oExcel = null; If IsNothing(oCom) Then Exit Sub Try Runtime.InteropServices.Marshal.ReleaseComObject(oCom) Catch ex As Exception Debug.WriteLine(ex) Finally oCom = Nothing End Try End Sub End Class #End Region #Region "clsHebExcel" Public Class clsHebExcel : Inherits clsHebOffice ' clsHebExcel : classe pour héberger Excel, basée sur clsHebOffice Private Const sClasseObjetExcel$ = "Excel.Application" Private Const sNomProcessExcel$ = "Excel" Public oXL As Object = Nothing Public Sub New(Optional bInterdireAppliAvant As Boolean = True, _ Optional bReutiliserInstance As Boolean = False) MyBase.New(sNomProcessExcel, sClasseObjetExcel, _ bInterdireAppliAvant, bReutiliserInstance) Me.oXL = Me.m_oApp End Sub Public Overloads Shared Function bOuvert() As Boolean bOuvert = clsHebOffice.bOuvert(sNomProcessExcel) End Function Public Sub Fermer(ByRef oSht As Object, ByRef oWkb As Object, bQuitter As Boolean, _ Optional bFermerClasseur As Boolean = True, _ Optional bLibererXLSiResteOuvert As Boolean = True) ' Liberer correctement le classeur, et le femer si demandé, ' et quitter Excel si demandé If bFermerClasseur AndAlso Not IsNothing(oWkb) Then 'msgDelegue.AfficherMsg("Fermeture du classeur...") Try oWkb.Close(SaveChanges:=False) ' Si Excel 2007 veut sauver qqch.: Non merci. Catch ex As Exception Debug.WriteLine(ex) End Try End If LibererObjetCom(oSht) LibererObjetCom(oWkb) ' Conserver Excel ouvert (par exemple pour visualiser l'actualisation d'un classeur) ' on libère oXL dans le cas général (sauf si on doit continuer d'utiliser l'instance ' par ex. pour effectuer d'autres traitements) If Not bQuitter Then If bLibererXLSiResteOuvert Then LibererObjetCom(Me.oXL) Exit Sub End If If Not IsNothing(Me.oXL) Then Try 'msgDelegue.AfficherMsg("Fermeture d'Excel...") If Me.bMonInstanceOuverte() Then Me.oXL.Quit() Catch ex As Exception ' L'application a été fermée par l'utilisateur, on n'y a plus accès ' ou bien on tente d'utiliser l'objet Me.oXL qui a déjà été libéré ' "Un objet COM qui a été séparé de son RCW sous-jacent ne peut pas être utilisé." Debug.WriteLine(ex) End Try 'msgDelegue.AfficherMsg("Libération d'Excel...") LibererObjetCom(Me.oXL) End If Me.Quitter() End Sub End Class #End Region #Region "clsHebWord" Public Class clsHebWord : Inherits clsHebOffice ' clsHebWord : classe pour héberger Word, basée sur clsHebOffice Private Const sClasseObjetWord$ = "Word.Application" Private Const sNomProcessWrd$ = "Winword" '"Word" Public oWrd As Object = Nothing Public Sub New(Optional bInterdireAppliAvant As Boolean = True) MyBase.New(sNomProcessWrd, sClasseObjetWord, bInterdireAppliAvant) oWrd = Me.m_oApp End Sub Public Overloads Shared Function bOuvert() As Boolean bOuvert = clsHebOffice.bOuvert(sNomProcessWrd) End Function End Class #End Region #Region "clsHebNav" Public Class clsHebNav ' clsHebNav : classe pour héberger un navigateur (Internet Explorer ou Firefox) Private Const sNomProcessIE$ = "iexplore" Private Const sNomProcessFireFox$ = "firefox" Public oAppNav As Object = Nothing Private m_iIdProcess% Public Sub New(sURL$) Me.m_iIdProcess = 0 ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() OuvrirAppliAssociee(sURL, bVerifierFichier:=False) ' Liste des processus après le mien : la différence me donnera l'Id du mien Dim aProcessAp() As Process = Process.GetProcesses() Dim i%, j% Dim bMonProcessNav As Boolean For j = 0 To aProcessAp.GetUpperBound(0) Dim sNomProcess$ = aProcessAp(j).ProcessName If sNomProcess = sNomProcessIE Or sNomProcess = sNomProcessFireFox Then bMonProcessNav = True ' Parcours des processus avant le mien For i = 0 To aProcessAv.GetUpperBound(0) Dim sNomProcess1$ = aProcessAv(i).ProcessName If sNomProcess1 = sNomProcessIE Or _ sNomProcess1 = sNomProcessFireFox Then If aProcessAp(j).Id = aProcessAv(i).Id Then ' S'il existait avant, ce n'était pas le mien bMonProcessNav = False Exit For End If End If Next i If bMonProcessNav = True Then ' Maintenant que j'ai son Id, je pourrai le controler Me.m_iIdProcess = aProcessAp(j).Id Exit For End If End If Next j End Sub Public Function bOuvert() As Boolean ' On peut savoir si l'utilisateur a fermé le navigateur ouvert ' par l'application If Me.m_iIdProcess = 0 Then Return False Try Return Not Process.GetProcessById(Me.m_iIdProcess).HasExited() Catch 'ex As Exception ' On vient juste de fermer Return False End Try End Function Public Sub Quitter() If Me.m_iIdProcess = 0 Then Exit Sub 'Process.GetProcessById(Me.m_iIdProcess).Kill() Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess) ' Même si l'instance a été fermée, monProc est toujours valide : ' ce test n'est pas suffisant If Not IsNothing(monProc) Then Try ' 15/05/2009 Libérer avant de tuer le processus LibererObjetCom(Me.oAppNav) 'Me.oAppNav = Nothing : Déjà fait ' Si l'instance ne nous appartient pas, on ne peut pas la fermer ' mais on ne reçoit aucune exception ! monProc.Kill() ' On ne peut pas interroger immédiatement ExitCode, seule solution : ' vérifier si l'appli est toujours ouverte avec l'iIdProcess 'If monProc.ExitCode = -1 Then ' ' MainModule vaut alors {"Accès refusé"} ' Debug.WriteLine("Impossible de fermer " & _ ' Me.m_sNomProcess & " : " & monProc.MainModule.ToString) 'End If Catch ex As Exception Debug.WriteLine(ex) End Try End If End Sub Public Shared Sub LibererObjetCom(ByRef oCom As Object) ' ByRef car on fait oCom = Nothing) ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing If IsNothing(oCom) Then Exit Sub Try Runtime.InteropServices.Marshal.ReleaseComObject(oCom) Catch Finally oCom = Nothing End Try End Sub End Class #End Region modUtil.vb Module modUtilitaires ' Module de fonctions utilitaires Public Sub AfficherMsgErreur( _ Optional sTitreFct$ = "", _ Optional sInfo$ = "", Optional sDetailMsgErr$ = "", _ Optional bCopierMsgPressePapier As Boolean = True) 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 bCopierMsgPressePapier Then CopierPressePapier(sMsg) MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) End Sub Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional sTitreFct$ = "", Optional sInfo$ = "", _ Optional sDetailMsgErr$ = "", _ Optional bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception '<System.Diagnostics.DebuggerStepThrough()> _ Public Function iConv%(sVal$, Optional iValDef% = -1) If String.IsNullOrEmpty(sVal) Then iConv = iValDef : Exit Function Try iConv = CInt(sVal) Catch iConv = iValDef End Try End Function End Module modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... 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 modUtilReg.vb ' Fichier modUtilReg.vb : Module de gestion de la base de registre ' --------------------- Imports Microsoft.Win32 Module modUtilReg ' Microsoft Win32 to Microsoft .NET Framework API Map : Registry Functions ' http://msdn.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions Public Const sDossierShell$ = "shell" Public Const sDossierCmd$ = "command" Public Function bAjouterTypeFichier(sExtension$, sTypeFichier$, _ Optional sDescriptionExtension$ = "", _ Optional bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de fichier à une application par défaut ' (via le double-clic ou bien le menu contextuel Ouvrir) ' Exemple : associer .dat à mon application.exe Try If bEnlever Then If bCleRegistreCRExiste(sExtension) Then Registry.ClassesRoot.DeleteSubKeyTree(sExtension) End If Else If Not bCleRegistreCRExiste(sExtension) Then Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension) rk.SetValue("", sTypeFichier) If sDescriptionExtension.Length > 0 Then rk.SetValue("Content Type", sDescriptionExtension) End If End Using 'rk.Close() End If End If Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterTypeFichier") Return False End Try End Function Public Function bAjouterMenuContextuel(sTypeFichier$, sCmd$, _ Optional bPrompt As Boolean = True, _ Optional bEnlever As Boolean = False, _ Optional sDescriptionCmd$ = "", _ Optional sCheminExe$ = "", _ Optional sCmdDef$ = """%1""", _ Optional sDescriptionTypeFichier$ = "", _ Optional bEnleverTypeFichier As Boolean = False) As Boolean ' Ajouter un menu contextuel dans la base de registre ' de type ClassesRoot : fichier associé à une application standard ' Exemple : ajouter le menu contextuel "Convertir en Html" sur les fichiers projet VB6 ' sTypeFichier = "VisualBasic.Project" ' sCmd = "ConvertirEnHtml" ' sDescriptionCmd = "Convertir en Html" ' sCheminExe = "C:\Program Files\VB2Html\VB2Html.exe" Try ' D'abord vérifier si la clé principale existe If Not bCleRegistreCRExiste(sTypeFichier) Then If bEnlever Then bAjouterMenuContextuel = True : Exit Function Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sTypeFichier) If sDescriptionTypeFichier.Length > 0 Then rk.SetValue("", sDescriptionTypeFichier) End If End Using End If Dim sCleDescriptionCmd$ = sTypeFichier & "\" & sDossierShell & "\" & sCmd If bEnlever Then If bEnleverTypeFichier Then ' Si c'est un type de fichier créé à l'occasion ' il faut aussi le supprimer (mais seulement dans ce cas) If bCleRegistreCRExiste(sTypeFichier) Then Registry.ClassesRoot.DeleteSubKeyTree(sTypeFichier) If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre", _ MsgBoxStyle.Information, m_sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, m_sTitreMsg) End If Else If bCleRegistreCRExiste(sCleDescriptionCmd) Then Registry.ClassesRoot.DeleteSubKeyTree(sCleDescriptionCmd) If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, m_sTitreMsg) Else If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "est introuvable dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, m_sTitreMsg) End If End If bAjouterMenuContextuel = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sDescriptionCmd) End Using 'rk.Close() Dim sCleCmd$ = sTypeFichier & "\" & sDossierShell & "\" & sCmd & "\" & sDossierCmd Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Ajouter automatiquement des guillemets " si le chemin contient au moins un espace If sCheminExe.IndexOf(" ") > -1 Then _ sCheminExe = """" & sCheminExe & """" rk.SetValue("", sCheminExe & " " & sCmdDef) End Using 'rk.Close() If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été ajouté avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", MsgBoxStyle.Information, m_sTitreMsg) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel", "Cause possible : L'application doit être lancée en tant qu'admin. pour cette opération.") Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, _ Optional sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' Note : la sous-clé est ici un "sous-dossier" (et non un "fichier") Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey( _ sCle & "\" & sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesCR$() = rkCRCle.GetSubKeyNames If IsNothing(rkCRCle) Then Return False End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, sSousCle$, _ ByRef sValSousCle$) As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' et si elle est trouvée, alors lire la valeur de la sous-clé ' Renvoyer True si la valeur de la sous-clé a pu être lue ' Note : la sous-clé est ici un "fichier" (et non un "sous-dossier") sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey(sCle) If IsNothing(rkCRCle) Then Return False ' Pour lire la valeur par défaut d'un "dossier", laisser "" Dim oVal As Object = rkCRCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreLMExiste(sCle$, _ Optional sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional sNouvValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé LocalMachine existe dans la base de registre sValSousCle = "" Try Dim bEcriture As Boolean = False If sNouvValSousCle.Length > 0 Then bEcriture = True ' Si la clé n'existe pas, on passe dans le Catch Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sCle, _ writable:=bEcriture) ' Lecture de la valeur de la sous-clé (sous forme de "fichier") Dim oVal As Object = rkLMCle.GetValue(sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesLM$() = rkLMCle.GetSubKeyNames ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function bCleRegistreCUExiste(sCle$, _ Optional sSousCle$ = "", _ Optional ByRef sValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé CurrentUser existe dans la base de registre ' et si oui renvoyer la valeur de la sous-clé sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) Dim oVal As Object = rkCUCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCUCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function asListeSousClesCU(sCle$) As String() ' Renvoyer la liste des sous-clés de type CurrentUser asListeSousClesCU = Nothing Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) If IsNothing(rkCUCle) Then Exit Function asListeSousClesCU = rkCUCle.GetSubKeyNames End Using ' rkCUCle.Close() est automatiquement appelé Catch End Try End Function End Module