VBTextFinder v1.1.9.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmVBTxtFnd.vb 2.1 - Private Function bFichierDicoExiste 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 bIndexerDocument 3.5 - Private Function bInitDico 3.6 - Private Function bInitMotsCourants 3.7 - Private Function bInterruption 3.8 - Private Function bMotDico 3.9 - Private Function bSauvegarderIndex 3.10 - Private Function bSeparateurPhrases 3.11 - Private Function bValiderSauvegardeTmp 3.12 - Private Function iLireNumParagGPhrase% 3.13 - Private Function MarquerOccurrencesHtml 3.14 - Private Function sInfoDoc$ 3.15 - Private Function sInfoParag$ 3.16 - Private Function sLireCleDocPhrase$ 3.17 - Private Function sLireCodeDoc$ 3.18 - Private Function sLirePhrase$ 3.19 - Private Sub AfficherMessage 3.20 - Private Sub AfficherResultats 3.21 - Private Sub AjouterMotDejaTrouve 3.22 - Private Sub CreerDocIndexSimple 3.23 - Private Sub EcrireListeDocumentsIndexesIni 3.24 - Private Sub ExtraireCitations 3.25 - Private Sub GestionChapitrage 3.26 - Private Sub NoterPositionCurseur2 3.27 - Private Sub RegenererDocs 3.28 - Private Sub RestaurerPositionCurseur 3.29 - Public Delegate Sub GestEvAfficherMessage 3.30 - Public Function bCleDocExiste 3.31 - Public Function bConvertirDocEnTxt 3.32 - Public Function bHyperTexte 3.33 - Public Function bIndexerDocuments 3.34 - Public Function bLireIndex 3.35 - Public Function bMotExiste 3.36 - Public Function bQuitter 3.37 - Public Function bSeparateurMots 3.38 - Public Function iNbDocumentsIndexes% 3.39 - Public Function sCleDocDefaut$ 3.40 - Public Sub AfficherFichierIni 3.41 - Public Sub ChercherOccurrencesMot 3.42 - Public Sub ChercherOccurrencesMots 3.43 - Public Sub ComparerIndexSimple 3.44 - Public Sub CreerDocIndex 3.45 - Public Sub CreerDocIndexCitations 3.46 - Public Sub InitNouvelleRecherche 3.47 - Public Sub Interrompre 3.48 - Public Sub LireListeDocumentsIndexesIni 3.49 - Public Sub ListerDocumentsIndexes 3.50 - Public Sub NoterPositionCurseur 3.51 - Public Sub ReinitDico 3.52 - 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 sEnleverAccents$ 6.5 - Public Function sRognerDernierCar$ 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 - Public Function asArgLigneCmd 10.2 - Public Function asLignes 10.3 - Public Function asLireFichier 10.4 - Public Function bAjouterFichier 10.5 - Public Function bAjouterFichier 10.6 - Public Function bCopierArbo 10.7 - Public Function bCopierFichier 10.8 - Public Function bCopierFichiers 10.9 - Public Function bDeplacerDossier 10.10 - Public Function bDeplacerFichiers2 10.11 - Public Function bDeplacerFichiers3 10.12 - Public Function bDossierExiste 10.13 - Public Function bEcrireFichier 10.14 - Public Function bEcrireFichier 10.15 - Public Function bFichierExiste 10.16 - Public Function bFichierExisteFiltre 10.17 - Public Function bFichierExisteFiltre2 10.18 - Public Function bReencoder 10.19 - Public Function bRenommerDossier 10.20 - Public Function bRenommerFichier 10.21 - Public Function bSupprimerDossier 10.22 - Public Function bSupprimerFichier 10.23 - Public Function bSupprimerFichiersFiltres 10.24 - Public Function bTrouverFichier 10.25 - Public Function bVerifierCreerDossier 10.26 - Public Function iNbFichiersFiltres% 10.27 - Public Function sbLireFichier 10.28 - Public Function sCheminRelatif$ 10.29 - Public Function sConvNomDos$ 10.30 - Public Function sDossierParent$ 10.31 - Public Function sEnleverSlashFinal$ 10.32 - Public Function sEnleverSlashInitial$ 10.33 - Public Function sExtraireChemin$ 10.34 - Public Function sFormaterNumerique$ 10.35 - Public Function sFormaterNumerique2$ 10.36 - Public Function sFormaterTailleOctets$ 10.37 - Public Function sLecteurDossier$ 10.38 - Public Function sLireFichier$ 10.39 - Public Function sNomDossierFinal$ 10.40 - Public Function sNomDossierParent$ 10.41 - Public Function StringReadLine$ 10.42 - Public FunctionbFichierAccessible 10.43 - Public Sub New 10.44 - Public Sub OuvrirAppliAssociee 10.45 - Public Sub ProposerOuvrirFichier 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 2015")> <Assembly: AssemblyTrademark("VBTextFinder")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("1.1.9.*")> frmVBTxtFnd.vb ' VBTextFinder : un moteur de recherche de mot dans son contexte ' -------------------------------------------------------------- ' http://www.vbfrance.com/code.aspx?ID=46695 ' Documentation : VBTextFinder.html : ' http://patrice.dargenton.free.fr/CodesSources/VBTextFinder.html ' http://patrice.dargenton.free.fr/CodesSources/VBTextFinder.vbproj.html ' 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) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ ' Fichier 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(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkUnicode.CheckedChanged TitrerAppli() Me.oVBTxtFnd.m_bTexteUnicode = Me.chkUnicode.Checked End Sub Private Sub chkAccents_CheckedChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAccents.CheckedChanged TitrerAppli() Me.oVBTxtFnd.m_bIndexerAccents = Me.chkAccents.Checked End Sub Private Sub chkUnicode_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkUnicode.Click ' Si on clique alors sauver l'option m_bSauverOption_bTexteUnicode = True End Sub Private Sub chkAccents_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAccents.Click ' Si on clique alors sauver l'option m_bSauverOption_bIndexerAccents = True End Sub Private Sub frmVBTextFinder_Load(ByVal sender As Object, ByVal 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.m_bIndexerAccents = My.Settings.bIndexerAccents Me.oVBTxtFnd.m_bTexteUnicode = 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(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles MyBase.Activated Activer() End Sub Private Sub frmVBTextFinder_Closing(ByVal sender As Object, _ ByVal 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 End Sub Private Sub SauverConfig( _ ByVal pt As Point, _ ByVal sz As Size, _ Optional ByVal ws As Windows.Forms.FormWindowState = FormWindowState.Normal, _ Optional ByVal 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 ' 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 Me.oVBTxtFnd.m_bModeDirect Then 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) If Me.oVBTxtFnd.bConvertirDocEnTxt( _ Me.oVBTxtFnd.m_sCheminFichierTxtDirect, 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_bTexteUnicode Dim bMemAccents As Boolean = Me.oVBTxtFnd.m_bIndexerAccents If Me.oVBTxtFnd.bLireIndex() Then ' Si l'index contenait du unicode, alors passer en unicode Dim bUnicode As Boolean = Me.oVBTxtFnd.m_bTexteUnicode Dim bAccents As Boolean = Me.oVBTxtFnd.m_bIndexerAccents 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\Test.txt" Me.TxtCheminDocument.Text = Application.StartupPath & "\Tmp\LisezMoi.htm" 'Me.TxtCheminDocument.Text = Application.StartupPath & "\Tmp\LisezMoi.txt" End If End Sub #End Region #Region "Gestion des événements" Private Sub CmdChoisirFichierDoc_Click(ByVal eventSender As Object, _ ByVal 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) If Me.oVBTxtFnd.bConvertirDocEnTxt(sFichier, bSablier:=True) Then _ Me.TxtCheminDocument.Text = sFichier Me.oVBTxtFnd.Sablier(bDesactiver:=True) End If VerifierOperationsPossibles(bVerifDocumentSeul:=True) End Sub Private Sub CmdAjouterDocument_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdAjouterDocument.Click AjouterDocument() End Sub Private Sub CmdChercher_Click(ByVal eventSender As Object, ByVal eventArgs As EventArgs) _ Handles CmdChercher.Click Chercher() End Sub Private Sub CmdInterrompre_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles CmdInterrompre.Click Me.m_msgDelegue.m_bAnnuler = True Me.oVBTxtFnd.Interrompre() End Sub Private Sub TxtCheminDocument_TextChanged(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles TxtCheminDocument.TextChanged VerifierActivationCmdIndexer() End Sub Private Sub TxtCheminDocument_DoubleClick(ByVal sender As Object, ByVal e As EventArgs) _ Handles TxtCheminDocument.DoubleClick BasculerFiltreIndexationFichiers() End Sub Private Sub LstTypeIndex_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles lstTypeIndex.Click AfficherDescriptionDocIndex() End Sub Private Sub LstTypeIndex_DoubleClick(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles lstTypeIndex.DoubleClick CreerDocIndex() End Sub 'Private Sub LstTypeAffichResult_SelectedIndexChanged(ByVal eventSender As Object, _ ' ByVal eventArgs As EventArgs) Handles LstTypeAffichResult.SelectedIndexChanged ' ScrollParagPredef() 'End Sub Private Sub LstTypeAffichResult_Click(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles LstTypeAffichResult.Click ScrollParagPredef() End Sub Private Sub vsbZoomParag_ValueChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles vsbZoomParag.ValueChanged ScrollParag() End Sub Private Sub TxtMot_TextChanged(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles TxtMot.TextChanged VerifierOperationsPossibles() End Sub Private Sub TxtMot_KeyDown(ByVal eventSender As Object, _ ByVal 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(ByVal eventSender As Object, _ ByVal 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(ByVal sender As Object, ByVal 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(ByVal eventSender As Object, _ ByVal eventArgs As EventArgs) Handles TxtResultat.DoubleClick HyperTexte() End Sub Private Sub chkAfficherInfoResultat_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAfficherInfoResultat.Click Chercher() End Sub Private Sub chkAfficherInfoDoc_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAfficherInfoDoc.Click Chercher() End Sub Private Sub chkAfficherNumParag_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAfficherNumParag.Click Chercher() End Sub Private Sub chkAfficherNumPhrase_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkAfficherNumPhrase.Click Chercher() End Sub Private Sub chkNumerotationGlobale_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkNumerotationGlobale.Click Chercher() End Sub Private Sub chkAfficherNumOccur_Click(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkMotsDico.Click VerifierDico() End Sub Private Sub lbCodesLangues_Click(ByVal sender As Object, ByVal 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(ByVal sender As Object, _ ' ByVal e As EventArgs) Handles MyBase.DoubleClick ' ListerDocumentsIndexes() 'End Sub Private Sub cmdListeDoc_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdListeDoc.Click ListerDocumentsIndexes() End Sub Private Sub cmdListeDocHtml_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdListeDocHtml.Click ListerDocumentsIndexes(bHtml:=True) AfficherHtml(bVerifierIdem:=False) End Sub Private Sub tcOnglets_SelectedIndexChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles tcOnglets.SelectedIndexChanged AfficherHtml() End Sub Private Sub wbResultat_DocumentCompleted(ByVal sender As Object, _ ByVal 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(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdExporterTxt.Click If IsNothing(oVBTxtFnd.m_sbResultatTxt) Then Exit Sub Dim iEncodage% = iCodePageWindowsLatin1252 If oVBTxtFnd.m_bTexteUnicode 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 If Me.oVBTxtFnd.bIndexerDocuments(Me.TxtCheminDocument.Text) 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(ByVal 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 ByVal 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_bTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 If Not bEcrireFichier(sCheminHtmlTmp, oVBTxtFnd.m_sbResultatHtml, _ iEncodage:=iEncodage) 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 ByVal 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.iNbOccurences & " 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 ByVal 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 bFichierDicoExiste(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 Exit Sub 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" End Select End Sub Private Sub VerifierDico() If Me.chkMotsDico.Checked Then Exit Sub Dim sCheminDico0$ = "" If bFichierDicoExiste(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 bFichierDicoExiste(ByRef sCheminDicoFinal$) As Boolean Dim sCheminDico0 = Application.StartupPath & sCheminDico & "_" & _ Me.tbCodeLangue.Text & sExtTxt sCheminDicoFinal = sCheminDico0 Dim bExiste0 = bFichierExiste(sCheminDico0) 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(ByVal 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(ByVal sender As Object, _ ByVal e As clsMsgEventArgs) Handles m_msgDelegue.EvAfficherMessage Me.AfficherMessage(e.sMessage) End Sub Private Sub AfficherMsgDelegue(ByVal sender As Object, _ ByVal e As clsSablierEventArgs) Handles m_msgDelegue.EvSablier Sablier(e.bDesactiver) End Sub Private Sub Sablier(Optional ByVal bDesactiver As Boolean = False) ' Me.Cursor : Curseur de la fenêtre ' Cursor.Current : Curseur de l'application ' Me.Cursor : Curseur de la fenêtre 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(ByVal sender As Object, _ ByVal e As EventArgs) Handles cmdAjouterMenuCtx.Click AjouterMenuCtx() VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, _ ByVal 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(ByVal 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(ByVal 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(ByVal sender As Object, _ ByVal 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" ' 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" ' 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 ' Si Unicode alors conserver les accents et tous les caractères exotiques Public m_bIndexerAccents As Boolean Public m_bTexteUnicode 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 ' Hashtable des mots indexés avec pour clé : sMot sans accent (par défaut) ' Si on index 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) ' 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 '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°" #End Region #Region "Initialisation et gestion du formulaire" Public Sub Initialiser(ByVal msgDelegue As clsMsgDelegue, _ ByRef ctrlLstAfficher As System.Windows.Forms.ListBox, _ ByRef ctrlTypeIndex As System.Windows.Forms.ListBox, ByVal iTypeIndexSelect%) 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) '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 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(ByVal 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 ByVal bDesactiver As Boolean = False) Me.m_bSablierDesactive = bDesactiver Me.m_msgDelegue.Sablier(bDesactiver) End Sub #End Region #Region "Indexation" Public Function bConvertirDocEnTxt(ByRef sCheminFichierSelect$, _ ByVal bSablier As Boolean) As Boolean 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_bTexteUnicode) If bConvertirDocEnTxt Then AfficherMessage("Conversion en .txt terminée.") sCheminFichierSelect = sCheminFichierTxt End If If bSablier Then Sablier(bDesactiver:=True) End Function Public Function bIndexerDocuments(ByVal sCheminFichier$) 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) And _ Left$(sNomFichier, Len(sFichierVBTxtFnd)).ToLower <> _ sFichierVBTxtFnd.ToLower Then Dim bFichierTxtInexistant As Boolean = False If Not bConvertirDocEnTxt(sFichier, bSablier:=False) Then GoTo Fin Dim sNumFichier$ = "Doc n°" & i + 1 & " / " & iNbFichers + 1 & " : " ' Le document peut être déjà indexé bIndexerDocument(sFichier, sNumFichier) If m_bInterrompre Then GoTo Fin End If Next i Else If Not bIndexerDocument(sCheminFichier) 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(ByVal sCheminFichier$, _ Optional ByVal 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() 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 m_bIndexerChapitre Then 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 If ' Ajouter le document dans la collection If Not bAjouterDocument(sCleDoc, sCleDoc, sCheminFichier) 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 'Dim oDoc As clsDoc If m_colDocs.Contains(sCleDoc) Then oDoc = DirectCast(m_colDocs.Item(sCleDoc), clsDoc) m_sbChapitres.AppendLine(vbCrLf & oDoc.sChemin & " (" & oDoc.sCodeDoc & ") :") End If End If m_bIndexModifie = True ' Modification de l'index courant m_sMemExpression = "" ' La précédente recherche d'expression doit être refaite 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 <> iPosDebPhraseSuiv_old Then ' Debug.WriteLine("!") 'End If 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 m_bIndexerChapitre AndAlso iNumPhrase = 0 Then GestionChapitrage(sLigne, sPhrasePonct, sCleDoc, oDoc, _ iMaxTypeChapitrage, asTypesChapitrages, _ iNumChapitre, sCodeChapitre, bTypeChapExclusif, _ iMaxTypeChapitrageXL, asTypesChapitragesXL, _ iMaxTypeChapitrageMdb, asTypesChapitragesMdb) End If oPhrase = New clsPhrase oPhrase.iNumPhraseG = Me.iNbPhrasesG oPhrase.iNumPhraseL = iNbPhrasesL oPhrase.sClePhrase = Me.iNbPhrasesG.ToString ' Numéro de la phrase oPhrase.iNumParagrapheL = iNbParagL oPhrase.iNumParagrapheG = iNbParagG oPhrase.sCleDoc = sCleDoc oPhrase.sCodeChapitre = sCodeChapitre ' 02/08/2010 Remplacer les espaces insécables pour faciliter les recherches oPhrase.sPhrase = sPhrasePonct.Replace(Chr(iCodeASCIIEspaceInsecable), " "c) m_colPhrases.Add(oPhrase) ' ArrayList Dim asMots$() = asPhrases(iNumPhrase).Split(acSepMot) 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, m_bTexteUnicode) 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 .iNbOccurences += 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 .iNbOccurences = 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 bIndexerDocument = True End Function Private Sub GestionChapitrage(ByVal sLigne$, ByVal sPhrasePonct$, _ ByVal sCleDoc$, ByVal oDoc As clsDoc, _ ByVal iMaxTypeChapitrage%, ByVal asTypesChapitrages$(), _ ByRef iNumChapitre%, ByRef sCodeChapitre$, _ ByRef bTypeChapExclusif As Boolean, _ ByVal iMaxTypeChapitrageXL%, ByVal asTypesChapitragesXL$(), _ ByVal iMaxTypeChapitrageMdb%, ByVal 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, _ StringComparison.InvariantCultureIgnoreCase) 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(ByVal 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$(ByVal 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$(ByVal 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 ByVal bListerPhrases As Boolean = True, _ Optional ByVal bHtml As Boolean = False) ' Afficher la liste des documents indexés 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 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 sbResultat.AppendLine(oDoc.sChemin & " (" & oDoc.sCodeDoc & ")") 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(ByVal sCleDoc$, ByVal sCodeDoc$, _ ByRef sCheminFichier$, Optional ByVal 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 sChemin$, sCheminAIndexer$ Dim sFichier$ = "" 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 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(ByVal 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, m_bTexteUnicode) 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(ByVal 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 Dim iPos = sLigne.LastIndexOf(":") If iPos <= 0 Then Continue For Dim sCheminDoc = Left(sLigne, iPos) Dim sCodeDoc = Mid(sLigne, iPos + 2).Trim ' Vérifier si le document existe Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs If oDoc.sChemin = sCheminDoc Then ' 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 Exit For End If Next oDoc ' 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 oDoc = New clsDoc oDoc.sCle = sCodeDoc oDoc.sCodeDoc = sCodeDoc oDoc.sChemin = sCheminDoc Me.m_colDocsIni.Add(oDoc, sCodeDoc) Next sLigne 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 ByVal bAfficherIni As Boolean = False) ' Afficher la liste des documents indexés If Not bFichierAccessible(m_sCheminFichierIni, _ bPrompt:=True, bInexistOk:=True) Then Exit Sub Dim sb As New StringBuilder Dim oDoc As clsDoc For Each oDoc In Me.m_colDocs Dim sLigne$ = oDoc.sChemin & ":" & oDoc.sCodeDoc sb.Append(sLigne).Append(vbCrLf) Next oDoc For Each oDoc In Me.m_colDocsIni Dim sLigne$ = oDoc.sChemin & ":" & oDoc.sCodeDoc 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, ByVal iNbZoomParag%, _ ByVal bAfficherInfoResultat As Boolean, ByVal bAfficherInfoDoc As Boolean, _ ByVal bAfficherNumParag As Boolean, ByVal bAfficherNumPhrase As Boolean, _ ByVal bAfficherNumOccur As Boolean, ByVal bAfficherTiret As Boolean, _ ByVal 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, m_bTexteUnicode)) 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, ByVal iNbZoomParag%, _ ByVal bAfficherInfoResultat As Boolean, ByVal bAfficherInfoDoc As Boolean, _ ByVal bAfficherNumParag As Boolean, ByVal bAfficherNumPhrase As Boolean, _ ByVal bAfficherNumOccur As Boolean, ByVal bAfficherTiret As Boolean, _ ByVal 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, m_bTexteUnicode)) 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, m_bTexteUnicode) 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(ByVal sPhraseAAfficher$, ByVal 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, _ StringComparison.InvariantCultureIgnoreCase) > -1 OrElse _ sBaliseFerm.IndexOf(sExpression, _ StringComparison.InvariantCultureIgnoreCase) > -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, m_bTexteUnicode) 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, _ StringComparison.InvariantCultureIgnoreCase) If iPosDebOcc = -1 Then Exit Do Dim iLongPortionAv% = iPosDebOcc - iMemPosDebOcc - iMemLong Dim sPortionAv$ = sPhraseAAfficher.Substring(iDebRechOcc, iLongPortionAv) sb.Append(sPortionAv) '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 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(ByVal sExpressions$, ByVal alResultats As ArrayList, _ ByVal iNbZoomParag%, ByVal bAfficherInfoResultat As Boolean, _ ByVal bAfficherInfoDoc As Boolean, ByVal bAfficherNumParag As Boolean, _ ByVal bAfficherNumPhrase As Boolean, _ ByVal bAfficherNumOccur As Boolean, ByVal iNbOccurrencesTot%, _ ByVal bAfficherTiret As Boolean, _ ByVal sbResultat As StringBuilder, ByRef CtrlResultat As TextBox, _ ByVal alExpressions As ArrayList, ByVal 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(ByVal CtrlResultat As Windows.Forms.TextBox, _ ByVal bAfficherInfoResultat As Boolean, ByVal bAfficherNumParag As Boolean, _ ByVal 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(ByVal 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(ByVal CtrlResultat As Windows.Forms.TextBox, ByVal sMot$, _ ByVal iNumParagSel%, ByVal iNumPhraseSel%, ByVal iNumCarSel%, ByVal iLongSel%, _ ByVal iNbZoomParag%, ByVal 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(ByVal 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%(ByVal 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%(ByVal 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$(ByVal 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(ByVal 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(ByVal 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(ByVal 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(ByVal 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_bTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 Try Using fs As 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_bTexteUnicode 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 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.iNbOccurences) 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") 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 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_bTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 Try Using fs As IO.FileStream = 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_bTexteUnicode Then m_bTexteUnicode = True bRecommencer = True ElseIf Not bUnicode And m_bTexteUnicode Then m_bTexteUnicode = 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 ' 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 If Not bAjouterDocument(sCleDoc, sCodeDoc, sCheminDoc, 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 AfficherMessage("Lecture de l'index (mots) en cours... " & _ CInt(100.0! * lPosFichier / lPosFinFichier) & "%") 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, m_bTexteUnicode) 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.iNbOccurences += 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.iNbOccurences = 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) 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(ByVal 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, m_bTexteUnicode) Return True End Function Public Sub ReinitDico() m_htDico = Nothing ' 03/05/2014 Penser à recharger le dico si on change de langue End Sub Private Function bInitDico(ByVal 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, m_bTexteUnicode) 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(ByVal 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, m_bTexteUnicode) Return m_htDico.ContainsKey(sMotSansAccent) End Function Private Sub CreerDocIndexSimple(ByVal bMotsCourants As Boolean, ByVal sCodeLangIndex$, _ ByVal bNumeriques As Boolean, ByVal bMotsDico As Boolean, ByVal 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, m_bTexteUnicode) 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(ByVal 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 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: 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(ByVal sPhrase$, ByVal sSepGmO$, ByVal sSepGmF$, _ ByVal 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(ByVal sTypeIndex$, ByVal bMotsDico As Boolean, _ ByVal bMotsCourants As Boolean, ByVal sCheminDico0$, ByVal sCodeLangIndex$, _ ByVal bMotsSeulsDocIndex0 As Boolean, ByVal iMaxMotsCles%, _ ByVal bNumeriques As Boolean, ByVal sCodesLanguesIndex$) ' Fabriquer un index à partir de la collection de mots indexés 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 Not bMotsDico AndAlso IsNothing(m_htDico) Then If Not bInitDico(sCheminDico0) Then Exit Sub 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 Exit Sub End If If Not m_bIndexerAccents Then _ sMotsCourants = sEnleverAccents(sMotsCourants, m_bTexteUnicode) Dim bTriFreq As Boolean If sTypeIndex <> sIndexAlpha Then bTriFreq = True Dim sTitre$, sListeMax$ Dim sExplication$ = "" Dim iNbDocIndexes% = Me.m_colDocs.Count() sTitre = "Document index de VBTextFinder" If Not bMotsDico And Not bMotsCourants Then sTitre = "Document index (hors mots du dictionnaire et mots courants " & _ sCodeLangIndex & ") de VBTextFinder" ElseIf Not bMotsDico Then sTitre = "Document index (hors mots du dictionnaire " & _ sCodeLangIndex & ") de VBTextFinder" ' 16/01/2011 Manque une ) ici ElseIf Not bMotsCourants Then sTitre = "Document index (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 Exit Sub If Not bFichierAccessible(sCheminDoc, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Exit Sub 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.iNbOccurences > lMaxOcc Then lMaxOcc = oMot.iNbOccurences 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, m_bTexteUnicode) asComplexifieurs(4) = sEnleverAccents(Config.sComplexifieurs4, m_bTexteUnicode) asComplexifieurs(5) = sEnleverAccents(Config.sComplexifieurs5, m_bTexteUnicode) 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 Not bMotsDico AndAlso bMotDico(oMot.sMot) Then Continue For 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, m_bTexteUnicode) End If If Not bMotsCourants AndAlso InStr(sMotsCourants, " " & sCleMot & " ") > 0 Then Continue For End If If bBiGramme Then ' Test bigrammes Dim sMotBrut$ = DirectCast(de.Key, String) sMotBrut = sEnleverAccents(sMotBrut, m_bTexteUnicode) 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 GoTo MotSuivant End If If bMotsCles Then If InStr(sMotsCourants, " " & sCleMot & " ") > 0 Then GoTo MotSuivant End If If oMot.iNbOccurences < 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.iNbOccurences & " : " & oMot.sMot & sListeRef End If ' Ne peut pas marcher avec une SortedList car la clé n'est pas unique ! sCle = Format(oMot.iNbOccurences, 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.iNbOccurences & 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, m_bTexteUnicode) 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 sFormatOcc = "0.00%" sFormatOcc = "0.000%" Dim lOccMax& = 0 Dim lOccTot& = 0 For Each de In htBiG oBG = DirectCast(de.Value, clsBiGramme) lOccTot += oBG.iNbOccurences If oBG.iNbOccurences > lOccMax Then lOccMax = oBG.iNbOccurences Next de For Each de In htBiG oBG = DirectCast(de.Value, clsBiGramme) Dim sFreq$ = Format(oBG.iNbOccurences / lOccMax, sFormatOcc) 'sFreq = Format(oBG.iNbOccurences, sFormatOcc) sFreq = Format(oBG.iNbOccurences / lOccTot, sFormatOcc) 'oBG.iNbOccurences & " : " Dim sBG$ = sFreq & " : " & oBG.sBiGramme 'Dim sCle$ = Format(oBG.iNbOccurences, sFormatOcc) & " : " & 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 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_bTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 If Not bEcrireFichier(sCheminTxt, sb, iEncodage:=iEncodage) Then Sablier(bDesactiver:=True) : Exit Sub ' Si Word n'est pas installé, ne plus essayer de l'ouvrir If Not bWord Then GoTo Fin AfficherMessage("Ouverture de Microsoft Word...") If bCreerDocIndex2(sCheminTxt, sCheminDoc, sTitre, sExplication, lNbMotsIndexes, _ Me.m_colDocs, m_bInterrompre, bWord, m_bTexteUnicode, sCodeLangIndex) Then AfficherMessage("Création du document index terminée.") ProposerOuvrirFichier(sCheminDoc) End If Fin: Sablier(bDesactiver:=True) If Not bWord Then ProposerOuvrirFichier(sCheminTxt) 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$(ByVal 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$(ByVal oPhrase As clsPhrase) sInfoParag = _ "§G:" & oPhrase.iNumParagrapheG & _ ", §L:" & oPhrase.iNumParagrapheL & _ ", Ph.G:" & oPhrase.iNumPhraseG & _ " Ph.L:" & oPhrase.iNumPhraseL & " : " End Function #End Region End Class modConfig.vb ' Fichier modConfig.vb : Module de configuration ' ---------------------- Module Config 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" ' 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 Public Const iCodeASCIIEspaceInsecable% = 160 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é ' 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 iNbOccurences% ' 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(ByVal iNbPhrases0%) 'lNbPhrases = lNbPhrases0 'ReDim m_alNumPhrases(lNbPhrases - 1) Me.aiNumPhrase = New ArrayList(iNbPhrases0) End Sub Public Sub AjouterNumPhrase3(ByVal 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 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(ByVal bw As IO.BinaryWriter, ByVal 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(ByVal 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(ByVal 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$(ByVal sTexte$, ByVal sCar$) Dim sTexte2$ = sTexte.TrimEnd If sTexte2.EndsWith(sCar) Then sRognerDernierCar = Left$(sTexte2, sTexte2.Length - 1) Else sRognerDernierCar = sTexte2 End If End Function Public Function sEnleverAccents$(ByVal sChaine$, bTexteUnicode As Boolean, _ Optional ByVal bMinuscule As Boolean = True) ' Enlever les accents If sChaine.Length = 0 Then sEnleverAccents = "" : Exit Function Const sEncodageIso8859_15$ = "iso-8859-15" Const sEncodageIso8859_8$ = "iso-8859-8" 'Const sEncodageDest$ = "windows-1252" ' Frédéric François, cœur ' iso-8859-8 -> windows-1252 : Frederic Francois, cour ' Meilleure solution ' windows-1251 -> windows-1252 : Frederic Francois, c?ur ' Ancienne solution ' iso-8859-15 -> windows-1252 : Frédéric François, c½ur ' Utile pour détecter <> ' Codepage 1241 = "windows-1251" = cyrillic ' Tableau de caractères sur 8 bit 'Dim aOctets As Byte() = GetEncoding(1251).GetBytes(sChaine) ' Chaîne de caractères sur 7 bit 'sEnleverAccents = ASCII.GetString(aOctets) ' Ok mais reste cœur qui est converti en c?ur Dim iEncodageDest% = iCodePageWindowsLatin1252 If bTexteUnicode Then iEncodageDest = iEncodageUnicodeUTF8 Dim encodage1252 As Encoding = GetEncoding(iCodePageWindowsLatin1252) Dim encodage8859_8 As Encoding = GetEncoding(sEncodageIso8859_8) Dim encodageDest As Encoding = GetEncoding(iEncodageDest) Dim encodageIso8859_15 As Encoding = GetEncoding(sEncodageIso8859_15) Dim aOctets As Byte() = encodage8859_8.GetBytes(sChaine) ' "iso-8859-8" sEnleverAccents = encodageDest.GetString(aOctets) ' 1252 ou UTF8 'If bDebug Then Debug.WriteLine("' " & sEncodageSrc & " -> " & sEncodageDest & " : " & sEnleverAccents) ' Détection des caractères propres à iso-8859-15 : ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ ' http://fr.wikipedia.org/wiki/ISO_8859-15 If String.Compare(encodageIso8859_15.GetString( _ encodage1252.GetBytes(sChaine)), sChaine) = 0 Then GoTo Fin Dim i% = 0 Dim iLen% = sChaine.Length Dim sChaineIso$ = encodageIso8859_15.GetString(encodageDest.GetBytes(sChaine)) Dim ac1, ac2, ac3 As Char() ac1 = sChaine.ToCharArray ac2 = sChaineIso.ToCharArray ac3 = sEnleverAccents.ToCharArray Dim sbDest As New StringBuilder For i = 0 To iLen - 1 If ac1(i) = ac2(i) Then sbDest.Append(ac3(i)) Else Select Case ac1(i) ' ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ Case "¤"c : sbDest.Append("o") Case "¦"c : sbDest.Append("|") Case "¨"c : sbDest.Append("..") Case "´"c : sbDest.Append("'") Case "¸"c : sbDest.Append(",") Case "¼"c : sbDest.Append("1/4") Case "½"c : sbDest.Append("1/2") Case "¾"c : sbDest.Append("3/4") Case "€"c : sbDest.Append("E") Case "Š"c : sbDest.Append("S") Case "š"c : sbDest.Append("s") Case "Ž"c : sbDest.Append("Z") Case "ž"c : sbDest.Append("z") Case "œ"c : sbDest.Append("oe") Case "Œ"c : sbDest.Append("OE") Case "Ÿ"c : sbDest.Append("Y") Case Else 'If bDebug Then Debug.WriteLine("?? : " & ac1(i) & ac2(i) & ac3(i)) sbDest.Append(ac1(i)) ' 22/05/2010 Laisser le car. si non trouvé End Select End If Next i sEnleverAccents = sbDest.ToString Fin: If bMinuscule Then sEnleverAccents = sEnleverAccents.ToLower End Function End Module modUtilLT.vb ' Fichier modUtilLT.vb : Module de fonctions utilitaires en liaison tardive ' --------------------- Option Strict Off ' Module non strict Module modUtilitairesLiaisonTardive Public Function bConvertirDocEnTxt2(ByVal sCheminFichierSelect$, _ ByVal sCheminFichierTxt$, ByVal sCheminDossierCourant$, _ ByVal msgDelegue As clsMsgDelegue, ByVal bTexteUnicode As Boolean) As Boolean ' Convertir un fichier .doc ou .html en .txt Dim oWrdH As clsHebWord = Nothing 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) ' 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) .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 bTexteUnicode Then iEncodage = iEncodageUnicodeUTF8 oWrdH.oWrd.ActiveDocument.SaveAs( _ FileName:=sCheminFichierTxt, FileFormat:=wdFormatText, _ Encoding:=iEncodage, LineEnding:=wdCRLF, AllowSubstitutions:=False, _ AddBiDiMarks:=False) ' 02/05/2010 Ne pas ajouter d'espace de présentation oWrdH.oWrd.ActiveDocument.Close() 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 ' http://www.vbfrance.com/code.aspx?id=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(ByVal sNomProcess$, ByVal sClasseObjet$, _ Optional ByVal bInterdireAppliAvant As Boolean = True, _ Optional ByVal 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(ByVal 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 ByVal bInterdireAppliAvant As Boolean = True, _ Optional ByVal 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, ByVal bQuitter As Boolean, _ Optional ByVal bFermerClasseur As Boolean = True, _ Optional ByVal 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 ByVal 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(ByVal 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 ByVal sTitreFct$ = "", _ Optional ByVal sInfo$ = "", Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal 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 ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception '<System.Diagnostics.DebuggerStepThrough()> _ Public Function iConv%(ByVal sVal$, Optional ByVal 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$, ByVal sFiltre$, ByVal sExtDef$, _ ' ByVal sTitre$, Optional ByVal sInitDir$ = "", _ ' Optional ByVal bDoitExister As Boolean = True, _ ' Optional ByVal 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(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt 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(ByVal sCheminFiltre$, ByVal sFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim 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(ByVal sCheminFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If sCheminFiltre.Length = 0 Then 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%(ByVal sCheminDossier$, ByVal sFiltre$) ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt Dim di As New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then Return 0 Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo Return fi.GetLength(0) End Function Public Function bTrouverFichier(ByVal sChemin$, ByVal sFiltre$, ByRef sCheminFichierTrouve$, _ Optional ByVal 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(ByVal sCheminSrc$, ByVal sCheminDest$, _ Optional ByVal bPromptErr As Boolean = True, _ Optional ByVal bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then 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 And 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(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _ Optional ByVal 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(ByVal sCheminFichier$, _ Optional ByVal 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(ByVal sCheminDossier$, ByVal sFiltre$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt ' Si le dossier n'existe pas, on considère que c'est un succès If Not bDossierExiste(sCheminDossier) Then 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(ByVal sSrc$, ByVal sDest$, _ Optional ByVal bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then 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(ByVal sSrc$, ByVal sDest$) As Boolean ' Renommer ou déplacer une arborescence de fichiers ' Attention : cette fonction nécessite la suppression du dossier src ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3 ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\ ' Cette fonction est déjà dans : modUtilFichierLT.vb Dim bStatut As Boolean, sListeErr$ = "" If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Return False Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Return False Return True End Function Public Function bDeplacerFichiers3(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _ Optional ByVal bConserverDest As Boolean = True, _ Optional ByVal sExtDest$ = "", Optional ByVal sPrefixe$ = "") As Boolean ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination ' en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination ' (option par défaut pour conserver la date) If Not bVerifierCreerDossier(sCheminDest) Then Return False Dim bChExt As Boolean = False If sExtDest.Length > 0 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(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False, _ Optional ByVal bPromptFermer As Boolean = False, _ Optional ByVal bInexistOk As Boolean = False, _ Optional ByVal bPromptRetenter As Boolean = False, _ Optional ByVal bLectureSeule As Boolean = False, _ Optional ByVal 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) bFichierAccessible = False If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, 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 Using fs As New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ 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 End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub ProposerOuvrirFichier(ByVal sCheminFichier$, _ Optional ByVal sInfo$ = "") If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sMsg$ = _ "Le fichier " & IO.Path.GetFileName(sCheminFichier) & _ " a été créé avec succès :" & vbLf & _ sCheminFichier If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _ Optional ByVal bMax As Boolean = False, _ Optional ByVal bVerifierFichier As Boolean = True, _ Optional ByVal 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 Dim 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 Sub Public Function sFormaterTailleOctets$(ByVal lTailleOctets&, _ Optional ByVal bDetail As Boolean = False, _ Optional ByVal 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 Or rNbMo >= 1 Or 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 sFormaterNumerique$(ByVal rVal!, _ Optional ByVal bSupprimerPt0 As Boolean = True, _ Optional ByVal 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 Dim nfi As Globalization.NumberFormatInfo = _ New Globalization.NumberFormatInfo ' Définition des spérateurs numériques nfi.NumberGroupSeparator = " " ' Séparateur des milliers, millions... nfi.NumberDecimalSeparator = "." ' Séparateur décimal ' 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = iNbDecimales ' 1 décimale de précision sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormaterNumerique = sFormaterNumerique.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormaterNumerique = sFormaterNumerique.Replace(sb.ToString, "") End If End If End Function Public Function sFormaterNumerique2$(ByVal rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 'sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général ' Vérifier , et . : sFormaterNumerique2 = rVal.ToString("n").Replace(",00", "").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(ByVal sCheminDossier$, _ Optional ByVal 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(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() 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(ByVal sCheminDossierSrc$, ByVal 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(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$, _ Optional ByVal bPromptErr As Boolean = True) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bRenommerDossier ' Roir aussi My.Computer.MoveDirectory en DotNet2 If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then 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(ByVal sCheminDossier$, _ Optional ByVal 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) And 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$(ByVal sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp ' (à renommer plutot en sCheminDossierParent ?) ' Ex. avec un chemin de fichier ' C:\Tmp\MonFichier.txt -> C:\Tmp ' Ex. avec un chemin de fichier avec filtre ' C:\Tmp\*.txt -> C:\Tmp sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Function sNomDossierFinal$(ByVal sCheminDossier$) ' Renvoyer le nom du dernier dossier à partir du chemin du dossier ' Exemples : ' C:\Tmp\Tmp\MonDossier -> MonDossier ' C:\MonDossier\ -> MonDossier ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé) sNomDossierFinal = sCheminDossier sCheminDossier = sEnleverSlashFinal(sCheminDossier) Dim iPosDossier% = sCheminDossier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1) End Function Public Function sExtraireChemin$(ByVal sCheminFichier$, _ Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", _ Optional ByRef sNomFichierSansExt$ = "") ' Retourner le chemin du fichier passé en argument ' Non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension ' Exemple : ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier) sNomFichier = IO.Path.GetFileName(sCheminFichier) sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier) sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt) End Function Public Function sNomDossierParent$(ByVal sCheminDossierOuFichier$, _ Optional ByVal sCheminReference$ = "") ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier ' sauf si le dossier parent n'existe pas : chemin de référence ' Exemples avec un dossier : ' C:\Tmp\Tmp\MonDossier -> \Tmp\MonDossier ' C:\MonDossier -> \MonDossier ' Exemples avec un fichier : ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt sNomDossierParent = "" Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier) ' Si c'est le chemin de référence, on le renvoit tel quel Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier) If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function Dim iFin% = iPosDossier - 1 Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin) If iPosDossierParent < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent) End Function Public Function sCheminRelatif$(ByVal sCheminFichier$, ByVal sCheminReference$) ' Renvoyer le chemin relatif au chemin de référence ' à partir du chemin complet du fichier ' Exemples avec C:\ pour le chemin de référence ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt ' Exemple avec C:\Tmp1 pour le chemin de référence ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(ByVal sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashFinal = "" : Exit Function If sChemin.EndsWith("\") Then sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1) Else sEnleverSlashFinal = sChemin End If End Function Public Function sEnleverSlashInitial$(ByVal sChemin$) ' Enlever le slash au début du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashInitial = "" : Exit Function If sChemin.StartsWith("\") Then sEnleverSlashInitial = sChemin.Substring(1) Else sEnleverSlashInitial = sChemin End If End Function Public Function bCopierArbo(ByVal sSrc$, ByVal sDest$, _ ByRef bStatut As Boolean, _ ByRef sListeErr$, Optional ByVal sListeErrExcep$ = "") As Boolean ' Copier une arborescence de fichiers ' en retournant bStatut : Succès ou Echec de la fonction récursive ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est ' indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers ' de ce rapport si on sait déjà qu'on ne pourra les copier) ' 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 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, True) Catch ex As Exception If sListeErrExcep.IndexOf(" " & sNomElements & " ") = -1 Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next Return bStatut End Function Public Function sLecteurDossier$(ByVal sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False 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 Using fs As 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)) 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 : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Exit Function End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim bDebut As Boolean = False 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 Using fs As 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)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbLireFichier.Append(vbCrLf) bDebut = True sbLireFichier.Append(sLigne) Loop While True End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") End Try End Function Public Function asLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False, _ Optional ByVal bVerifierCrCrLf As Boolean = False, _ Optional ByVal bUnicodeUTF8 As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier asLireFichier = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If If bLectureSeule Then Using fs As New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encodage) ' 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 : End Using Else asLireFichier = IO.File.ReadAllLines(sCheminFichier, encodage) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False, _ Optional ByVal bEncodageUTF8 As Boolean = False, _ Optional ByVal bEncodageUTF16 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Return False End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding 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 sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sbContenu.ToString()) 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(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False, _ Optional ByVal bEncodageUFT8 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPromptErr As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier ' 03/02/2014 bPromptErr:=bPromptErr et non bPromptErr:=True If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPromptErr) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Return False End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding 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 sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sContenu) 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(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal 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 '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(ByVal sCheminFichier$, _ ByVal 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 '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(ByVal sCheminFichier$) As Boolean ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then 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(ByVal sLigneCmd$, _ Optional ByVal bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim iNbArg%, sFichier$, sSepar$ Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean sCmd = sLigneCmd iLen = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Si le premier caractère est un guillement, c'est un nom long If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong Then iDeb2 += 1 ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2 iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLen + 1 'sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2)) sFichier = Mid$(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim$(sFichier) If sFichier <> "" Then ReDim Preserve asArgs(iNbArg) asArgs(iNbArg) = sFichier iNbArg += 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop Const iCodeGuillemets% = 34 Dim iNumArg% For iNumArg = 0 To UBound(asArgs) 'If bSupprimerEspaces Then ' asArgs(iNumArg) = Trim$(asArgs(iNumArg)) 'Else ' asArgs(iNumArg) = asArgs(iNumArg) 'End If Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" End If Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(ByVal sChaine$, _ Optional ByVal bLimit8Car As Boolean = False, _ Optional ByVal bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 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 And iCode <= 90 Then bMaj = True If iCode >= 192 And iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If 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 bConserverSignePlus And iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 And iCode <= 90) Then bOk = True If (iCode >= 97 And iCode <= 122) Then bOk = True If (iCode >= 48 And iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function #End Region #Region "Classe Flux Chaine" ' Equivalent de mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' mais pour une chaine : optimisation des flux Public Class clsFluxChaine Private m_iNumLigne% = 0 ' Debug Private m_sChaine$ Private m_iPos% = 0 Private c13 As Char = ChrW(13) ' vbCr Private c10 As Char = ChrW(10) ' vbLf Public Sub New(ByVal sChaine$) m_sChaine = sChaine End Sub Public Function asLignes(Optional ByVal 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 ByVal 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(ByVal sExtension$, ByVal sTypeFichier$, _ Optional ByVal sDescriptionExtension$ = "", _ Optional ByVal bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de ficier à 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(ByVal sTypeFichier$, ByVal sCmd$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByVal bEnlever As Boolean = False, _ Optional ByVal sDescriptionCmd$ = "", _ Optional ByVal sCheminExe$ = "", _ Optional ByVal sCmdDef$ = """%1""", _ Optional ByVal sDescriptionTypeFichier$ = "", _ Optional ByVal 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, sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, 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, 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, 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, sTitreMsg) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel") Return False End Try End Function Public Function bCleRegistreCRExiste(ByVal sCle$, _ Optional ByVal 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(ByVal sCle$, _ ByVal 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(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional ByVal 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(ByVal sCle$, _ Optional ByVal 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(ByVal 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