VBFileFind v1.0.9.*Table des procédures 1 - AssemblyInfo.vb 2 - frmVBFileFind.vb 2.1 - Private Delegate Sub GestEvAfficherMsg 2.2 - Private Function iLireTypeEncodage% 2.3 - Private Sub Activation 2.4 - Private Sub AfficherFSIEv 2.5 - Private Sub AfficherInfo 2.6 - Private Sub AfficherMessage 2.7 - Private Sub AfficherMsg 2.8 - Private Sub AfficherMsgDirect 2.9 - Private Sub AfficherResultats 2.10 - Private Sub AjouterElement 2.11 - Private Sub AjouterMenuCtx 2.12 - Private Sub AjusterColonnesResultats 2.13 - Private Sub BackgroundWorker1_DoWork 2.14 - Private Sub BackgroundWorker1_RunWorkerCompleted 2.15 - Private Sub chkDateMax_Click 2.16 - Private Sub chkDateMin_Click 2.17 - Private Sub chkTailleMax_Click 2.18 - Private Sub chkTailleMin_Click 2.19 - Private Sub chkTexteRech_Click 2.20 - Private Sub cmdAjouterMenuCtx_Click 2.21 - Private Sub cmdEnleverMenuCtx_Click 2.22 - Private Sub cmdLancer_Click 2.23 - Private Sub cmdParcourir_Click 2.24 - Private Sub cmdStop_Click 2.25 - Private Sub DepilerJob 2.26 - Private Sub DepilerJobInterne 2.27 - Private Sub EnleverMenuCtx 2.28 - Private Sub frmVBFileFind_Activated 2.29 - Private Sub frmVBFileFind_FormClosing 2.30 - Private Sub frmVBFileFind_KeyPress 2.31 - Private Sub frmVBFileFind_Load 2.32 - Private Sub GestSablier 2.33 - Private Sub lvResultats_DoubleClick 2.34 - Private Sub lvResultats_Resize 2.35 - Private Sub MAJTailleDossiers 2.36 - Private Sub Sablier 2.37 - Private Sub tbTailleMax_TextChanged 2.38 - Private Sub tbTailleMin_TextChanged 2.39 - Private Sub Terminer 2.40 - Private Sub VerifierMenuCtx 2.41 - Public Sub SauverConfig 3 - clsVBFileFind.vb 3.1 - Private Function abConvMin 3.2 - Private Function abConvMin 3.3 - Private Function bContientTxt 3.4 - Private Function bContientTxt 3.5 - Private Function bElementCorrespondant 3.6 - Private Function bFichierContientOccFileStream 3.7 - Private Function bFichierContientOccStreamReader 3.8 - Private Sub Depart 3.9 - Private Sub EmpilerJob 3.10 - Private Sub RechercheOcc 3.11 - Private Sub ResetVariables 3.12 - Private Sub VerifierPause 3.13 - Property bPause 3.14 - Public Function bResteJob 3.15 - Public Function sDepilerJob$ 3.16 - Public Sub CalculerTaillesDossiers 3.17 - Public Sub ChercherArbo 3.18 - Public Sub cmdStart 3.19 - Public Sub cmdStop 3.20 - Public Sub LireInfos 3.21 - Public Sub New 4 - modDepart.vb 4.1 - Private Sub Depart 4.2 - Public Sub DefinirTitreApplication 4.3 - Public Sub Main 5 - modUtil.vb 5.1 - Public Function iConv% 5.2 - Public Function lConv 5.3 - Public Sub AfficherMsgErreur2 5.4 - Public Sub Attendre 5.5 - Public Sub CopierPressePapier 5.6 - Public Sub TraiterMsgSysteme_DoEvents 6 - clsAfficherMsg.vb 6.1 - Public ReadOnly Property bDesactiver 6.2 - Public ReadOnly Property fsi 6.3 - Public ReadOnly Property iNumFichierEnCours% 6.4 - Public ReadOnly Property lAvancement 6.5 - Public ReadOnly Property sMessage$ 6.6 - Public ReadOnly Property sMessage$ 6.7 - Public Sub AfficherAvancement 6.8 - Public Sub AfficherFichierEnCours 6.9 - Public Sub AfficherFSIEnCours 6.10 - Public Sub AfficherMsg 6.11 - Public Sub New 6.12 - Public Sub New 6.13 - Public Sub New 6.14 - Public Sub New 6.15 - Public Sub New 6.16 - Public Sub New 6.17 - Public Sub New 6.18 - Public Sub New 6.19 - Public Sub New 6.20 - Public Sub Sablier 6.21 - Public Sub Tick 7 - clsHashQueue.vb 7.1 - Private Sub EnqueueDictionary 7.2 - Public Shadows Function Contains 7.3 - Public Shadows Function Dequeue 7.4 - Public Shadows Sub Clear 7.5 - Public Shadows Sub Enqueue 7.6 - Public Sub New 7.7 - Public Sub New 7.8 - Public Sub New 8 - modSendKeys.vb 8.1 - Private Function sInsererEspacesTxt$ 8.2 - Private Sub New 8.3 - Public Shared FunctionShowWindow% 8.4 - Public Sub OuvrirBlocNotes 9 - modUtilFichier.vb 9.1 - Private Function abLireFichier 9.2 - Private Function sbRemoveDiacritics 9.3 - Private Function sRemoveDiacritics$ 9.4 - Public Function asArgLigneCmd 9.5 - Public Function asLignes 9.6 - Public Function asLireFichier 9.7 - Public Function bAjouterFichier 9.8 - Public Function bAjouterFichier 9.9 - Public Function bCopierArbo 9.10 - Public Function bCopierFichier 9.11 - Public Function bCopierFichiers 9.12 - Public Function bDeplacerDossier 9.13 - Public Function bDeplacerFichiers2 9.14 - Public Function bDeplacerFichiers3 9.15 - Public Function bDossierExiste 9.16 - Public Function bEcrireFichier 9.17 - Public Function bEcrireFichier 9.18 - Public Function bFichierAccessible 9.19 - Public Function bFichierExiste 9.20 - Public Function bFichierExisteFiltre 9.21 - Public Function bFichierExisteFiltre2 9.22 - Public Function bListToHashSet 9.23 - Public Function bReencoder 9.24 - Public Function bRenommerDossier 9.25 - Public Function bRenommerFichier 9.26 - Public Function bSupprimerDossier 9.27 - Public Function bSupprimerFichier 9.28 - Public Function bSupprimerFichiersFiltres 9.29 - Public Function bTrouverFichier 9.30 - Public Function bVerifierCreerDossier 9.31 - Public Function iNbFichiersFiltres% 9.32 - Public Function LireEncodage 9.33 - Public Function LireEncodageTED 9.34 - Public Function sbEnleverAccents 9.35 - Public Function sbLireFichier 9.36 - Public Function sbLireFichier 9.37 - Public Function sCheminRelatif$ 9.38 - Public Function sConvNomDos$ 9.39 - Public Function sDossierParent$ 9.40 - Public Function sEnleverAccents$ 9.41 - Public Function sEnleverSlashFinal$ 9.42 - Public Function sEnleverSlashInitial$ 9.43 - Public Function sExtraireChemin$ 9.44 - Public Function sFormaterNumerique$ 9.45 - Public Function sFormaterNumerique2$ 9.46 - Public Function sFormaterNumeriqueLong$ 9.47 - Public Function sFormaterTailleKOctets$ 9.48 - Public Function sFormaterTailleOctets$ 9.49 - Public Function sLecteurDossier$ 9.50 - Public Function sLireFichier$ 9.51 - Public Function sNomDossierFinal$ 9.52 - Public Function sNomDossierParent$ 9.53 - Public Function StringReadLine$ 9.54 - Public Sub New 9.55 - Public SubOuvrirAppliAssociee 9.56 - Public SubOuvrirDossier 9.57 - Public SubProposerOuvrirFichier 10 - modUtilReg.vb 10.1 - Public Function asListeSousClesCU 10.2 - Public Function bAjouterMenuContextuel 10.3 - Public Function bAjouterTypeFichier 10.4 - Public Function bCleRegistreCRExiste 10.5 - Public Function bCleRegistreCRExiste 10.6 - Public Function bCleRegistreCUExiste 10.7 - Public Function bCleRegistreLMExiste 11 - ucSortableListView.vb 11.1 - Private Function sLireColonne$ 11.2 - Private Sub EnleverColoriageTri 11.3 - Private Sub InitializeComponent 11.4 - Private Sub list_ColumnClick 11.5 - Protected Overrides Sub Dispose 11.6 - Public Function Compare% 11.7 - Public Sub DefinirMsgDelegue 11.8 - Public Sub DesactiverTri 11.9 - Public Sub New 11.10 - Public Sub New 11.11 - Public Sub New AssemblyInfo.vb Imports System.Reflection Imports System.Runtime.InteropServices <Assembly: AssemblyTitle("VBFileFind")> <Assembly: AssemblyDescription( "VBFileFind : Pour remplacer la recherche de fichiers de Windows, " & "d'après File Searcher in C# By Manfred Bittersam, 24/04/2009, " & "https://www.codeproject.com/Articles/35044/File-Searcher-in-C")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("VBFileFind")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2024")> <Assembly: AssemblyTrademark("")> <Assembly: AssemblyVersion("1.0.9.*")> frmVBFileFind.vb ' VBFileFind : Recherche de fichiers pour remplacer celle de Windows ' D'après la source : ' File Searcher in C# ' By Manfred Bittersam | 24 Apr 2009 ' A freeware file searcher in C# ' https://www.codeproject.com/Articles/35044/File-Searcher-in-C ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ Imports System.Text ' Pour StringBuilder Imports System.IO ' Pour DirectoryInfo ' https://www.nuget.org/packages/OSVersionExt ' https://github.com/pruggitorg/detect-windows-version Imports OSVersionExtension ' Pour OSVersion.GetOSVersion Public Class frmVBFileFind Private Const bUtiliserFiltreExclusion As Boolean = True #Region "Interface" Public m_sCheminDossier$ = "" Public Enum enumColonnes iColChemin = 0 iColTaille = 1 iColTailleTxt = 2 iColDate = 3 iColDateAcces = 3 End Enum #End Region #Region "Déclarations" Private m_bUtiliserBackgroundWorker As Boolean = False ' 25/09/2016 Const sCmdLancer$ = "Lancer" Const sCmdPause$ = "Pause" Const sCmdPoursuivre$ = "Poursuivre" Const sCmdStop$ = "Stop" Const sTxtRechercheEnCours$ = "Recherche en cours..." Const sTxtRechercher$ = "Veuillez saisir un texte à rechercher." Private Shared ReadOnly m_oVerrou As New Object ' 25/11/2012 ' Menu contextuel Private Const sMenuCtx_TypeDossier$ = "Directory" Private Const sMenuCtx_TypeLecteur$ = "Drive" ' 16/12/2012 ' Il vaut mieux indiquer VBFileFind devant Rechercher pour rappeler quel logiciel ajoute cette clé Private Const sMenuCtx_CleCmdRechercher$ = "VBFileFind.Rechercher" Private Const sMenuCtx_CleCmdRechercherDescription$ = "Rechercher avec VBFileFind" Private Const dDateNulle As Date = #12:00:00 AM# Private m_dTpsDeb As DateTime = Now Private m_dTpsPrecedListeFichiers As DateTime = Now Private m_dTpsPrecedBarreMsg As DateTime = Now Private WithEvents m_msgDelegue As clsMsgDelegue = New clsMsgDelegue Private Delegate Sub GestEvAfficherMsg(msg As clsMsgEventArgs) Private m_gestAffichage As GestEvAfficherMsg Private m_llviQueue As New List(Of ListViewItem) ' Résultats à afficher Private m_oVBFF As New clsVBFileFind Private m_bRechEnCours As Boolean = False Private m_sRaccourciBlocNotesOccurrSuiv$ = "" Private m_b1ereOuvertureBlocNotes As Boolean = False Private m_iMemTailleRech% = 0 Private m_bInit As Boolean = False ' frm déjà initialisé ? Private m_BlocNotesRechercheDesactivee As Boolean = False ' 22/06/2024 #End Region #Region "Initialisations" ' Note : l'appel à InitialiserFenetre() se trouve dans la fonction New() ' cf. frmVBFileFind.Designer.vb Private Sub InitialiserFenetre() ' Reprendre la taille et la position précédente de la fenêtre ' Positionnement de la fenêtre par le code : mode manuel Me.StartPosition = FormStartPosition.Manual If bDebug Then Me.StartPosition = FormStartPosition.CenterScreen ' 25/10/2015 ' Fixer la position et la taille de la feuille sauvées dans le fichier .exe.config Me.Location = My.Settings.frmPosition Me.Size = My.Settings.frmTaille Me.WindowState = DirectCast(My.Settings.frm_EtatFenetre, FormWindowState) ' 16/10/2016 Me.lvResultats.Columns(enumColonnes.iColChemin).Width = My.Settings.TailleColChemin Me.lvResultats.Columns(enumColonnes.iColTaille).Width = 0 'My.Settings.TailleColTaille Me.lvResultats.Columns(enumColonnes.iColTailleTxt).Width = My.Settings.TailleColTailleTxt Me.lvResultats.Columns(enumColonnes.iColDate).Width = My.Settings.TailleColDate Me.lvResultats.Columns(enumColonnes.iColDateAcces).Width = My.Settings.TailleColDateAcces m_iMemTailleRech = Me.lvResultats.Width End Sub Private Sub frmVBFileFind_Load(sender As Object, e As EventArgs) _ Handles MyBase.Load ' 04/05/2014 modUtilFichier peut maintenant être compilé dans une dll DefinirTitreApplication(sTitreMsg) ' 11/11/2012 m_gestAffichage = New GestEvAfficherMsg(AddressOf AfficherMsgDirect) Me.lblInfo.Text = "" AfficherMsg("") ' 15/07/2012 ' Disable automatic sorting to enable manual sorting. 'Me.lvResultats.Sorting = SortOrder.None Me.lvResultats.Columns(enumColonnes.iColChemin).Tag = GetType(String) Me.lvResultats.Columns(enumColonnes.iColTaille).Tag = GetType(Long) ' Colonne masquée, c'est la colonne texte en octets qui est affichée Me.lvResultats.Columns(enumColonnes.iColTaille).Width = 0 Me.lvResultats.Columns(enumColonnes.iColTailleTxt).Tag = GetType(String) Me.lvResultats.Columns(enumColonnes.iColDate).Tag = GetType(Date) Me.lvResultats.Columns(enumColonnes.iColDateAcces).Tag = GetType(Date) Me.lvResultats.m_iColTriSrc = enumColonnes.iColTailleTxt Me.lvResultats.m_iColTriDest = enumColonnes.iColTaille Me.lvResultats.DefinirMsgDelegue(m_msgDelegue) VerifierMenuCtx() Dim sVersion$ = " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sDebug$ = " - Debug" Dim sTxt$ = Me.Text & sVersion If bDebug Then sTxt &= sDebug Me.Text = sTxt Me.tbCheminDossier.Text = My.Settings.CheminRecherche If Me.m_sCheminDossier.Length > 0 Then Me.tbCheminDossier.Text = Me.m_sCheminDossier End If Me.chkSousDossiers.Checked = My.Settings.bInclureSousDossiers Me.tbFiltresFichiers.Text = My.Settings.Filtre Me.tbFiltresFichiersExclus.Text = My.Settings.FiltreExclusion ' 25/10/2015 Me.chkDateMin.Checked = My.Settings.bDateMin If My.Settings.DateMin <> dDateNulle Then _ Me.dtpDateMin.Value = My.Settings.DateMin Me.chkDateMax.Checked = My.Settings.bDateMax If My.Settings.DateMax <> dDateNulle Then _ Me.dtpDateMax.Value = My.Settings.DateMax ' 20/06/2022 Me.chkTailleMin.Checked = My.Settings.bTailleMin If My.Settings.TailleMin.Length > 0 Then _ Me.tbTailleMin.Text = My.Settings.TailleMin Me.chkTailleMax.Checked = My.Settings.bTailleMax If My.Settings.TailleMax.Length > 0 Then _ Me.tbTailleMax.Text = My.Settings.TailleMax Me.chkTexteRech.Checked = My.Settings.bContient Me.chkCasse.Checked = My.Settings.bCasse Me.tbTexteRech.Text = My.Settings.MotARechercher Me.chkBlocNotes.Checked = My.Settings.bOuvrirBlocNotes ' 21/06/2024 Le bloc-notes ne peut plus recevoir des envois de touches Dim bWindows11 As Boolean = False ' Note : on peut mettre tout le code dans une seule classe, mais alors elle fait 31 Ko ! Dim sVersionOS$ = OSVersion.GetOperatingSystem().ToString() If sVersionOS = "Windows11" Then bWindows11 = True If bWindows11 Then ' C'est seulement la recherche qui est désactivée (via l'envoi de touches clavier) m_BlocNotesRechercheDesactivee = True Me.toolTip1.SetToolTip(Me.chkBlocNotes, "Ouvrir le fichier avec le Bloc-notes (via un double-clic dans la liste trouvée), " & "sinon ouvrir avec l'application associée, ou bien ouvrir le dossier dans l'explo" & "rateur de fichiers. La recherche du mot trouvée ne marche plus à partir de Windows 11.") End If Me.pnlTexteRech.Enabled = Me.chkTexteRech.Checked Me.rbASCII.Checked = False Me.rbUnicode.Checked = False Me.rbDbleEncod.Checked = False If My.Settings.TypeEncodage = clsVBFileFind.TypeEncodage.ASCII_Ou_Unicode Then _ Me.rbDbleEncod.Checked = True If My.Settings.TypeEncodage = clsVBFileFind.TypeEncodage.ASCII Then _ Me.rbASCII.Checked = True If My.Settings.TypeEncodage = clsVBFileFind.TypeEncodage.Unicode Then _ Me.rbUnicode.Checked = True If My.Settings.TypeEncodage = clsVBFileFind.TypeEncodage.Detecter Then _ Me.rbDetect.Checked = True m_bUtiliserBackgroundWorker = My.Settings.bBackgroundWorker ' 24/09/2016 ' 24/09/2016 Configuration automatique en anglais Dim ci As Globalization.CultureInfo = Globalization.CultureInfo.CurrentCulture Dim bAnglais As Boolean = False If ci.Name.StartsWith("en-") Then bAnglais = True m_sRaccourciBlocNotesOccurrSuiv = My.Settings.RaccourciBlocNotesOccurrSuivAlt_S If bAnglais Then m_sRaccourciBlocNotesOccurrSuiv = My.Settings.RaccourciBlocNotesOccurrSuivAnglaisAlt_F End If If bDebug Then Me.tbCheminDossier.Text = Application.StartupPath 'Me.chkTailleMin.Checked = True 'Me.chkTailleMax.Checked = True Me.tbTailleMin.Text = "3000000" Me.tbTailleMax.Text = "1000" Me.chkSousDossiers.Checked = False Me.tbFiltresFichiers.Text = "*.txt" 'Me.tbFiltresFichiersExclus.Text = "" ' Test de recherche de ièce dans Pièces : ce n'est pas possible, car Pièces est encodé ' à la fois sur un et deux octets : è est encodé par C3 A8 en UTF-8, ' avec ou sans nomenclature (Byte Order Marks) : ' -P -i -- -è -c -e -s ' 50 69 C3 A8 63 65 73 ' Note : pour ouvrir l'éditeur Hexadécimal dans Visual Studio Code : ' Bouton droit sur l'onglet du fichier ouvert : Reopen Editor With... : Hex Editor (à installer avant) Me.tbTexteRech.Text = "Pieces" ' Marche 'Me.tbTexteRech.Text = "Pièces" ' Ne marche plus ! 'Me.rbDetect.Checked = True Me.chkTexteRech.Checked = True Me.pnlTexteRech.Enabled = True 'Me.chkCasse.Checked = False 'Me.chkDateMin.Checked = True 'Me.chkDateMax.Checked = False 'Me.dtpDateMin.Value = #1/1/2014# End If If Not bUtiliserFiltreExclusion Then Me.tbFiltresFichiersExclus.Enabled = False End If Activation(bActiver:=True) ' 17/09/2022 End Sub Private Sub frmVBFileFind_Activated(sender As Object, e As EventArgs) Handles Me.Activated m_bInit = True End Sub Private Function iLireTypeEncodage%() Dim iTypeEncodage% = clsVBFileFind.TypeEncodage.ASCII_Ou_Unicode If Me.rbASCII.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.ASCII If Me.rbUnicode.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.Unicode If Me.rbDetect.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.Detecter iLireTypeEncodage = iTypeEncodage End Function Private Sub frmVBFileFind_FormClosing(sender As Object, e As FormClosingEventArgs) Handles MyBase.FormClosing Me.m_oVBFF.cmdStop() SauverConfig(Me.Location, Me.Size, Me.WindowState) End Sub Public Sub SauverConfig( positionFen As Point, tailleFen As Size, Optional fws As Windows.Forms.FormWindowState = FormWindowState.Normal) ' 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\VBFileFind.exe_Url_xxx...xxx\1.0.x.xxxxx\user.config If fws = FormWindowState.Normal Then My.Settings.frmPosition = positionFen My.Settings.frmTaille = tailleFen My.Settings.frm_EtatFenetre = 0 ElseIf fws = FormWindowState.Minimized Then My.Settings.frm_EtatFenetre = 0 ' Remetre normal 1 ElseIf fws = FormWindowState.Maximized Then My.Settings.frm_EtatFenetre = 2 End If My.Settings.CheminRecherche = Me.tbCheminDossier.Text My.Settings.bInclureSousDossiers = Me.chkSousDossiers.Checked My.Settings.Filtre = Me.tbFiltresFichiers.Text My.Settings.FiltreExclusion = Me.tbFiltresFichiersExclus.Text ' 25/10/2015 My.Settings.bDateMin = Me.chkDateMin.Checked My.Settings.DateMin = Me.dtpDateMin.Value My.Settings.bDateMax = Me.chkDateMax.Checked My.Settings.DateMax = Me.dtpDateMax.Value ' 20/06/2022 My.Settings.bTailleMin = Me.chkTailleMin.Checked My.Settings.TailleMin = Me.tbTailleMin.Text My.Settings.bTailleMax = Me.chkTailleMax.Checked My.Settings.TailleMax = Me.tbTailleMax.Text My.Settings.bContient = Me.chkTexteRech.Checked My.Settings.bCasse = Me.chkCasse.Checked My.Settings.MotARechercher = Me.tbTexteRech.Text My.Settings.bOuvrirBlocNotes = Me.chkBlocNotes.Checked My.Settings.TypeEncodage = iLireTypeEncodage() ' 16/10/2016 My.Settings.TailleColChemin = Me.lvResultats.Columns(enumColonnes.iColChemin).Width My.Settings.TailleColTailleTxt = Me.lvResultats.Columns(enumColonnes.iColTailleTxt).Width My.Settings.TailleColDate = Me.lvResultats.Columns(enumColonnes.iColDate).Width My.Settings.TailleColDateAcces = Me.lvResultats.Columns(enumColonnes.iColDateAcces).Width ' Si l'infrastructure de l'appli. est activée, l'appel peut être automatique ' (simple case à cocher) My.Settings.Save() End Sub Private Sub frmVBFileFind_KeyPress(sender As Object, e As Windows.Forms.KeyPressEventArgs) Handles Me.KeyPress ' Si on presse la touche Entrée, alors envoyer la touche Tabulation ' pour passer au controle suivant (frm.KeyPreview = True pour que ça marche) If e.KeyChar = Microsoft.VisualBasic.ChrW(Keys.Return) Then SendKeys.Send("{TAB}") e.Handled = True End If End Sub #End Region #Region "Traitements" Private Sub chkTexteRech_Click(sender As Object, e As EventArgs) _ Handles chkTexteRech.Click Dim bActif As Boolean = Me.chkTexteRech.Checked Me.pnlTexteRech.Enabled = bActif End Sub Private Sub cmdParcourir_Click(sender As Object, e As EventArgs) _ Handles cmdParcourir.Click Dim dlg As New FolderBrowserDialog dlg.SelectedPath = Me.tbCheminDossier.Text If dlg.ShowDialog(Me) <> DialogResult.OK Then Exit Sub Me.tbCheminDossier.Text = dlg.SelectedPath End Sub Private Sub cmdLancer_Click(sender As Object, e As EventArgs) _ Handles cmdLancer.Click If Me.m_bRechEnCours Then Me.m_oVBFF.bPause = Not Me.m_oVBFF.bPause If Me.m_oVBFF.bPause Then Me.cmdLancer.Text = sCmdPoursuivre Else Me.cmdLancer.Text = sCmdPause End If Me.lvResultats.m_bNePasTrier = Not Me.m_oVBFF.bPause ' 18/11/2012 If Me.lvResultats.m_bNePasTrier Then Me.lvResultats.DesactiverTri() Exit Sub End If If Me.chkTexteRech.Checked AndAlso Me.tbTexteRech.Text = "" Then MessageBox.Show(sTxtRechercher, sTitreMsg, MessageBoxButtons.OK, MessageBoxIcon.Asterisk) Exit Sub End If Me.m_bRechEnCours = True ' 16/01/2011 Après le test précédant Me.lvResultats.m_bNePasTrier = True ' 25/11/2012 Me.lvResultats.DesactiverTri() Me.m_dTpsDeb = Now() Me.m_dTpsPrecedListeFichiers = Now() Me.m_dTpsPrecedBarreMsg = Now() Dim sMsgREC$ = sTxtRechercheEnCours Me.lblInfo.Text = sMsgREC If Not My.Settings.bSignalerChaqueFichierBarreEtat Then AfficherMsg(sMsgREC) Me.lvResultats.Items.Clear() Dim fileNames As String() = Me.tbFiltresFichiers.Text.Split(New Char() {";"c}) Dim fileNamesExcl As String() = Me.tbFiltresFichiersExclus.Text.Split(New Char() {";"c}) Dim validFileNames As New List(Of String) For Each fileName As String In fileNames Dim trimmedFileName As String = fileName.Trim If trimmedFileName.Length > 0 Then validFileNames.Add(trimmedFileName) Next Dim validFileNamesExcl As New List(Of String) For Each fileName As String In fileNamesExcl Dim trimmedFileName As String = fileName.Trim If trimmedFileName.Length > 0 Then validFileNamesExcl.Add(trimmedFileName) Next Dim iTypeEncodage As clsVBFileFind.TypeEncodage = clsVBFileFind.TypeEncodage.ASCII_Ou_Unicode ' Les 2 If Me.rbASCII.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.ASCII If Me.rbUnicode.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.Unicode If Me.rbDetect.Checked Then iTypeEncodage = clsVBFileFind.TypeEncodage.Detecter ' 20/06/2022 Dim lTailleMin& = 0 Dim lTailleMax& = 0 If Me.tbTailleMin.Text.Length > 0 Then lTailleMin = lConv(Me.tbTailleMin.Text) If Me.tbTailleMax.Text.Length > 0 Then lTailleMax = lConv(Me.tbTailleMax.Text) Dim prm As New clsVBFileFind.clsPrm( Me.tbCheminDossier.Text, Me.chkSousDossiers.Checked, validFileNames, validFileNamesExcl, Me.chkDateMin.Checked, Me.dtpDateMin.Value, Me.chkDateMax.Checked, Me.dtpDateMax.Value, Me.chkTailleMin.Checked, lTailleMin, Me.chkTailleMax.Checked, lTailleMax, Me.chkTexteRech.Checked, Me.chkCasse.Checked, Me.tbTexteRech.Text, iTypeEncodage, m_bUtiliserBackgroundWorker) Activation(bActiver:=False) ' Initialisation Me.m_oVBFF.cmdStart(prm, m_msgDelegue) If m_bUtiliserBackgroundWorker Then Me.BackgroundWorker1.WorkerSupportsCancellation = True DepilerJob() End Sub Private Sub cmdStop_Click(sender As Object, e As EventArgs) _ Handles cmdStop.Click Me.m_oVBFF.cmdStop() Terminer() End Sub Private Sub DepilerJob() ' Dépiler 1 job = une recherche dans un dossier AutreJob: If Not Me.m_oVBFF.bResteJob() Then Terminer() : Exit Sub ' Il faut laisser ce test en cas de réaffichage If m_bUtiliserBackgroundWorker AndAlso Me.BackgroundWorker1.IsBusy Then Exit Sub Dim sDossier$ = Me.m_oVBFF.sDepilerJob() If m_bUtiliserBackgroundWorker Then Me.BackgroundWorker1.RunWorkerAsync(sDossier) Else DepilerJobInterne(sDossier) ' Un job est terminé, afficher puis dépiler le job suivant jusqu'à la fin AfficherResultats() 'DepilerJob() ' Appel récursif ? Pas besoin : GoTo AutreJob End If End Sub Private Sub BackgroundWorker1_DoWork(sender As Object, e As System.ComponentModel.DoWorkEventArgs) Handles BackgroundWorker1.DoWork Dim arg As String = DirectCast(e.Argument, String) DepilerJobInterne(arg) e.Result = arg End Sub Private Sub DepilerJobInterne(sChemin$) Dim dirInfo As New DirectoryInfo(sChemin) ' 01/10/2016 Eviter de lancer une recherche si aucun filtre d'exclusion If bUtiliserFiltreExclusion AndAlso Me.tbFiltresFichiersExclus.Text.Length > 0 Then _ Me.m_oVBFF.ChercherArbo(dirInfo, bExclusion:=True) ' 25/10/2015 Me.m_oVBFF.ChercherArbo(dirInfo, bExclusion:=False) End Sub Private Sub BackgroundWorker1_RunWorkerCompleted(sender As Object, e As System.ComponentModel.RunWorkerCompletedEventArgs) _ Handles BackgroundWorker1.RunWorkerCompleted ' Un job est terminé, afficher puis dépiler le job suivant jusqu'à la fin AfficherResultats() 'Dim arg As String = DirectCast(e.Result, String) DepilerJob() End Sub Private Sub Terminer() Me.m_oVBFF.CalculerTaillesDossiers() AfficherResultats(bFin:=True) MAJTailleDossiers() Activation(bActiver:=True) Me.m_bRechEnCours = False Me.lvResultats.m_bNePasTrier = False End Sub Private Sub AfficherInfo(Optional bFin As Boolean = False) Dim dTpsFin As DateTime = Now Dim tsDiffTps As TimeSpan = dTpsFin.Subtract(Me.m_dTpsDeb) Dim iNbFichiersOuDossiersTrouves% = 0, lNbOctetsLus& = 0, lNbOctetsCompares& = 0, lNbOctetsFichiers& = 0, lTailleMoyFichier& = 0, iNbFichiersOuDossiers% = 0, iNbDossiersParcourus% = 0, iNbDossiers% = 0 Me.m_oVBFF.LireInfos(iNbFichiersOuDossiersTrouves, iNbFichiersOuDossiers, lNbOctetsLus, lNbOctetsCompares, lNbOctetsFichiers, lTailleMoyFichier, iNbDossiersParcourus, iNbDossiers) Dim rDebitLecture! = 0, rDebitCompare! = 0 ' Fichiers ou dossiers : objets ou éléments Dim sTrouves$ = iNbFichiersOuDossiersTrouves & "/" & iNbFichiersOuDossiers & " élément(s) trouvé(s)" Dim sb As New StringBuilder(sTrouves) ' 16/10/2016 Inutile d'afficher la taille si on ne fait pas de recherche dans les fichiers If Me.chkTexteRech.Checked Then If lNbOctetsLus > 0 Then sb.Append(", " & sFormaterTailleOctets(lNbOctetsLus) & " lus") If tsDiffTps.TotalSeconds > 0 Then rDebitLecture = CSng(lNbOctetsLus / tsDiffTps.TotalSeconds) sb.Append(" (" & sFormaterTailleOctets(CLng(rDebitLecture)) & "/sec.)") End If End If If lNbOctetsCompares > 0 Then sb.Append(", " & sFormaterTailleOctets(lNbOctetsCompares) & " comparés") If tsDiffTps.TotalSeconds > 0 Then rDebitCompare = CSng(lNbOctetsCompares / tsDiffTps.TotalSeconds) sb.Append(" (" & sFormaterTailleOctets(CLng(rDebitCompare)) & "/sec.)") End If End If If lNbOctetsFichiers > 0 Then sb.Append(", " & sFormaterTailleOctets(lNbOctetsFichiers) & " de fichiers parcourus") sb.Append(", taille moy.: " & sFormaterTailleOctets(lTailleMoyFichier)) 'If Me.chkTexteRech.Checked Then Dim rPC! = CSng(lNbOctetsLus / lNbOctetsFichiers) Dim rFreq! = 1 - rPC ' Fréquence du texte recherché sb.Append(" (fréq. texte : " & rFreq.ToString("0.0%") & ")") 'End If End If End If If iNbDossiersParcourus > 0 Then ' 25/09/2016 sb.Append(", " & iNbDossiersParcourus & " dossiers parcourus / " & iNbDossiers) End If If Me.m_oVBFF.m_lexErr.Count > 0 Then sb.Append(", " & Me.m_oVBFF.m_lexErr.Count & " erreur(s)") End If ' 02/09/2012 Correction du temps de recherche : + logique ! Dim iNbHeures% = CInt(Math.Truncate(tsDiffTps.TotalHours)) Dim iNbMinutes% = CInt(Math.Truncate(tsDiffTps.TotalMinutes - iNbHeures * 60)) Dim iNbSecondes% = CInt(Math.Truncate(tsDiffTps.TotalSeconds _ - iNbHeures * 3660 - iNbMinutes * 60)) Dim rNbMilliSec# = tsDiffTps.TotalMilliseconds _ - iNbHeures * 3660000 - iNbMinutes * 60000 - iNbSecondes * 1000 Dim rTot# = rNbMilliSec + iNbSecondes * 1000 + iNbMinutes * 60000 + iNbHeures * 3660000 Dim sTps$ = ", temps de recherche : " & iNbHeures.ToString() & "h " & iNbMinutes.ToString() & "' " & iNbSecondes.ToString() & "'' " & rNbMilliSec.ToString("0") & " msec." sb.Append(sTps) Dim sTxt$ = sb.ToString Me.lblInfo.Text = sTxt If Not bFin Then Exit Sub AfficherMsg(sTrouves) If Not My.Settings.bSignalerChaqueFichierBarreEtat Then AfficherMsg("Recherche terminée.") If Not My.Settings.bLogBilan Then Exit Sub Dim sCheminFichierLog$ = Application.StartupPath & "\VBFileFind.log" Dim sb0 As New StringBuilder sb0.AppendLine(Me.Text) sb0.AppendLine(Now & " : " & Me.tbCheminDossier.Text) sb0.AppendLine("Sous-dossiers = " & Me.chkSousDossiers.Checked) If Me.tbFiltresFichiersExclus.Text.Length > 0 Then sb0.AppendLine("Exclusions = " & Me.tbFiltresFichiersExclus.Text) End If If Me.chkTexteRech.Checked Then sb0.AppendLine("Recherche = " & Me.tbTexteRech.Text) sb0.AppendLine("Casse = " & Me.chkCasse.Checked & ", Type encodage = " & iLireTypeEncodage()) End If sb0.Append(sTxt) sb0.AppendLine("") For Each ex As Exception In Me.m_oVBFF.m_lexErr sb0.AppendLine(ex.Message) Next If Me.tbFiltresFichiersExclus.Text.Length > 0 Then sb0.AppendLine("") sb0.AppendLine("Dossiers exclus : " & m_oVBFF.m_hsExclus.Count) For Each sChemin As String In m_oVBFF.m_hsExclus sb0.AppendLine(sChemin) Next End If sb0.AppendLine("") sb0.AppendLine("Dossiers : " & m_oVBFF.m_hsDossiers.Count) For Each sChemin As String In m_oVBFF.m_hsDossiers sb0.AppendLine(sChemin) Next sb0.AppendLine("") sb0.AppendLine("Dossiers trouvés : " & m_oVBFF.m_hsDossiersTrouves.Count) For Each sChemin As String In m_oVBFF.m_hsDossiersTrouves sb0.AppendLine(sChemin) Next sb0.AppendLine("") sb0.AppendLine("Eléments trouvés : " & m_oVBFF.m_hsElementsTrouves.Count) For Each sChemin As String In m_oVBFF.m_hsElementsTrouves sb0.AppendLine(sChemin) Next bEcrireFichier(sCheminFichierLog, sb0) End Sub Private Sub Activation(bActiver As Boolean) If Not bActiver Then Me.m_msgDelegue.m_bAnnuler = False ' 19/03/2017 Me.cmdStop.Enabled = Not bActiver If bActiver Then Me.cmdLancer.Text = sCmdLancer Else Me.cmdLancer.Text = sCmdPause End If Me.tbCheminDossier.Enabled = bActiver Me.cmdParcourir.Enabled = bActiver Me.chkSousDossiers.Enabled = bActiver Me.tbFiltresFichiers.Enabled = bActiver If bUtiliserFiltreExclusion Then Me.tbFiltresFichiersExclus.Enabled = bActiver Else Me.tbFiltresFichiersExclus.Enabled = False End If Me.chkDateMin.Enabled = bActiver Me.dtpDateMin.Enabled = bActiver AndAlso Me.chkDateMin.Checked Me.chkDateMax.Enabled = bActiver Me.dtpDateMax.Enabled = bActiver AndAlso Me.chkDateMax.Checked ' 17/09/2022 Me.chkTailleMin.Enabled = bActiver Me.tbTailleMin.Enabled = bActiver AndAlso Me.chkTailleMin.Checked Me.chkTailleMax.Enabled = bActiver Me.tbTailleMax.Enabled = bActiver AndAlso Me.chkTailleMax.Checked Me.chkTexteRech.Enabled = bActiver Me.tbTexteRech.Enabled = bActiver Me.rbASCII.Enabled = bActiver Me.rbUnicode.Enabled = bActiver Me.rbDbleEncod.Enabled = bActiver Me.chkCasse.Enabled = bActiver Me.chkBlocNotes.Enabled = bActiver End Sub #End Region #Region "Affichage des résultats" Private Sub AfficherFSIEv(sender As Object, e As clsFSIEventArgs) _ Handles m_msgDelegue.EvAfficherFSIEnCours AjouterElement(e.fsi) End Sub Private Sub AfficherMessage(sender As Object, e As clsMsgEventArgs) _ Handles m_msgDelegue.EvAfficherMessage Me.tsslblBarreMessage.Text = e.sMessage End Sub Private Sub GestSablier(sender As Object, e As clsSablierEventArgs) _ Handles m_msgDelegue.EvSablier Sablier(e.bDesactiver) Me.Enabled = e.bDesactiver ' Test sur la possibilité d'annuler un tri : mais le pb c'est qu'on suspend ' l'affichage pour aller plus vite justement 'If Not e.bDesactiver Then ' Me.cmdLancer.Enabled = False ' Me.cmdStop.Enabled = True 'Else ' Me.cmdLancer.Enabled = True ' Me.cmdStop.Enabled = False 'End If End Sub Private Sub Sablier(Optional bDesactiver As Boolean = False) ' Me.Cursor : Curseur de la fenêtre ' Cursor.Current : Curseur de l'application If bDesactiver Then Me.Cursor = Cursors.Default Else Me.Cursor = Cursors.WaitCursor End If ' 19/03/2017 Ne rien faire de plus, sinon cela annule le sablier ! ' 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 'TraiterMsgSysteme_DoEvents() End Sub Private Sub AfficherMsg(sTxt$) If Not m_bUtiliserBackgroundWorker Then Me.tsslblBarreMessage.Text = sTxt Else ' 11/12/2012 Faire un appel indirect pour éviter l'erreur d'appel depuis un autre thread ' (l'erreur survient lorsque l'on redimensionne la fenêtre pendant une recherche) Dim e As New clsMsgEventArgs(sTxt) Dim args() As Object = {e} MyBase.Invoke(m_gestAffichage, args) End If End Sub Private Sub AfficherMsgDirect(msg As clsMsgEventArgs) Me.tsslblBarreMessage.Text = msg.sMessage End Sub Private Sub AjouterElement(fsi As IO.FileSystemInfo) Dim lvi As New ListViewItem lvi.Text = fsi.FullName Dim lvsiTailleTxt As New ListViewItem.ListViewSubItem Dim lvsiTailleL As New ListViewItem.ListViewSubItem If TypeOf fsi Is IO.FileInfo Then Dim fi As IO.FileInfo = DirectCast(fsi, IO.FileInfo) Dim lLong& = fi.Length ' Colonne masquée avec la taille exacte de chaque fichier, pour le tri lvsiTailleTxt.Text = lLong.ToString lvsiTailleL.Text = sFormaterTailleKOctets(lLong, bSupprimerPt0:=True) Else lvsiTailleTxt.Text = (0L).ToString lvsiTailleL.Text = "" End If lvi.SubItems.Add(lvsiTailleTxt) lvi.SubItems.Add(lvsiTailleL) Dim lvsiDate As New ListViewItem.ListViewSubItem lvsiDate.Text = (fsi.LastWriteTime.ToShortDateString & " " & fsi.LastWriteTime.ToShortTimeString) lvi.SubItems.Add(lvsiDate) Dim lvsiDateAcces As New ListViewItem.ListViewSubItem lvsiDateAcces.Text = (fsi.LastAccessTime.ToShortDateString & " " & fsi.LastAccessTime.ToShortTimeString) lvi.SubItems.Add(lvsiDateAcces) lvi.ToolTipText = fsi.FullName ' Colorer les dossiers If TypeOf fsi Is IO.DirectoryInfo Then lvi.BackColor = Color.LightYellow ' Ajouter l'élément dans une file d'attente If m_bUtiliserBackgroundWorker Then SyncLock m_oVerrou ' 25/11/2012 On ne peut pas énumérer la liste pendant un ajout Me.m_llviQueue.Add(lvi) End SyncLock Else Me.m_llviQueue.Add(lvi) End If If Not My.Settings.bSignalerChaqueFichierBarreEtat Then Exit Sub ' Afficher les éléments de la file d'attente à chaque 10è de sec. écoulée Dim dTpsFin As DateTime = Now Dim tsDiffTpsPreced As TimeSpan = dTpsFin.Subtract(Me.m_dTpsPrecedBarreMsg) If tsDiffTpsPreced.TotalSeconds < My.Settings.DelaiAffichageBarreMsgSec Then Exit Sub Me.m_dTpsPrecedBarreMsg = dTpsFin 'If My.Settings.bSignalerChaqueFichierBarreEtat Then AfficherMsg(lvi.Text) AfficherMsg(lvi.Text) End Sub Private Sub AfficherResultats(Optional bFin As Boolean = False) ' Traiter la file d'attente : afficher tous les résultats qu'elle contient ' Le plus svt possible afficher le fichier en cours de traitement ' pour donner l'impression de vitesse ' (mais par contre, pour la liste, pas besoin d'aller aussi vite) 'For Each lvi0 As ListViewItem In Me.m_llviQueue ' AfficherMsg(lvi0.Text) ' Exit For 'Next ' Afficher les éléments de la file d'attente à chaque 1/4 sec. écoulée If Not bFin Then Dim dTpsFin As DateTime = Now Dim tsDiffTpsPreced As TimeSpan = dTpsFin.Subtract(Me.m_dTpsPrecedListeFichiers) If tsDiffTpsPreced.TotalSeconds < My.Settings.DelaiAffichageListeFichiersSec Then Exit Sub Me.m_dTpsPrecedListeFichiers = dTpsFin End If Me.lvResultats.SuspendLayout() Me.SuspendLayout() ' En dernier Me.lvResultats.BeginUpdate() ' 21/07/2012 If m_bUtiliserBackgroundWorker Then SyncLock m_oVerrou ' 25/11/2012 On ne peut pas énumérer la liste pendant un ajout Dim iNbItems% = Me.m_llviQueue.Count For Each lvi0 As ListViewItem In Me.m_llviQueue ' Style possible pour chaque sous-item (pour colorier la colonne triée) lvi0.UseItemStyleForSubItems = False Me.lvResultats.Items.Add(lvi0) Next End SyncLock Else Dim iNbItems% = Me.m_llviQueue.Count For Each lvi0 As ListViewItem In Me.m_llviQueue ' Style possible pour chaque sous-item (pour colorier la colonne triée) lvi0.UseItemStyleForSubItems = False Me.lvResultats.Items.Add(lvi0) Next End If If bFin Then For Each ex As Exception In Me.m_oVBFF.m_lexErr Dim lvi As New ListViewItem lvi.UseItemStyleForSubItems = False lvi.Text = ex.Message lvi.BackColor = Color.Orange Me.lvResultats.Items.Add(lvi) Next If Not m_oVBFF.m_bSucces Then Dim lvi As New ListViewItem lvi.UseItemStyleForSubItems = False lvi.Text = m_oVBFF.m_sMsgErr lvi.BackColor = Color.Orange Me.lvResultats.Items.Add(lvi) End If End If Me.lvResultats.EndUpdate() ' 21/07/2012 Me.lvResultats.ResumeLayout() AfficherInfo(bFin) Me.ResumeLayout() ' En dernier aussi Me.m_llviQueue = New List(Of ListViewItem) End Sub Private Sub MAJTailleDossiers() Me.lvResultats.SuspendLayout() Me.SuspendLayout() ' En dernier Me.lvResultats.BeginUpdate() If m_bUtiliserBackgroundWorker Then SyncLock m_oVerrou ' On ne peut pas énumérer la liste pendant un ajout For Each lvi0 As ListViewItem In Me.lvResultats.Items Dim sCle$ = lvi0.Text If Me.m_oVBFF.m_dicoTaillesDossiers.ContainsKey(sCle) Then Dim lTailleSousDossier& = Me.m_oVBFF.m_dicoTaillesDossiers(sCle) lvi0.SubItems(enumColonnes.iColTaille).Text = lTailleSousDossier.ToString lvi0.SubItems(enumColonnes.iColTailleTxt).Text = sFormaterTailleKOctets(lTailleSousDossier, bSupprimerPt0:=True) End If Next End SyncLock Else For Each lvi0 As ListViewItem In Me.lvResultats.Items Dim sCle$ = lvi0.Text If Me.m_oVBFF.m_dicoTaillesDossiers.ContainsKey(sCle) Then Dim lTailleSousDossier& = Me.m_oVBFF.m_dicoTaillesDossiers(sCle) lvi0.SubItems(enumColonnes.iColTaille).Text = lTailleSousDossier.ToString lvi0.SubItems(enumColonnes.iColTailleTxt).Text = sFormaterTailleKOctets(lTailleSousDossier, bSupprimerPt0:=True) End If Next End If Me.lvResultats.EndUpdate() Me.lvResultats.ResumeLayout() Me.ResumeLayout() ' En dernier aussi End Sub #End Region #Region "Gestion des événements" Private Sub lvResultats_DoubleClick(sender As Object, e As EventArgs) _ Handles lvResultats.DoubleClick ' Ouvrir le fichier en question, soit par l'application associée ' soit via le bloc-notes (avec recherche de l'occurrence via SendKeys) If Me.lvResultats.SelectedItems.Count = 0 Then Exit Sub Dim sChemin As String = Me.lvResultats.SelectedItems.Item(0).Text If IO.Directory.Exists(sChemin) Then ' C'est un dossier : l'ouvrir OuvrirDossier(sChemin) Exit Sub End If If Not IO.File.Exists(sChemin) Then Exit Sub If Not Me.chkBlocNotes.Checked Then OuvrirAppliAssociee(sChemin) : Exit Sub Dim sTxt$ = "" If Me.chkTexteRech.Checked Then sTxt = Me.tbTexteRech.Text Dim bUnicode As Boolean = False Dim sExt$ = IO.Path.GetExtension(sChemin) ' Si on choisi les 2 types d'encodage, on ne peut pas savoir à priori le type ' Si le fichier est txt, alors même en unicode, il s'affiche normalement dans le bloc-notes ' (pas besoin d'ajouter des espaces après chaque caractère) ' Si on consulte un fichier binaire avec une occurrence trouvée en unicode ' alors ajouter des espaces après chaque caractère If Me.rbUnicode.Checked And sExt.ToLower <> ".txt" Then bUnicode = True ' 18/08/2016 Configurer selon la langue, en anglais un seul paramètre est différent OuvrirBlocNotes(sChemin, sTxt, Me.chkCasse.Checked, bUnicode, My.Settings.RaccourciBlocNotesRechercherCtrl_f, My.Settings.RaccourciBlocNotesSensibleCasseAlt_c, m_sRaccourciBlocNotesOccurrSuiv, My.Settings.ExeBlocNotes, m_b1ereOuvertureBlocNotes, My.Settings.DelaiMSec1OuvertureBlocNotes, bOuvrirSeulement:=m_BlocNotesRechercheDesactivee) m_b1ereOuvertureBlocNotes = True End Sub Private Sub lvResultats_Resize(sender As Object, e As EventArgs) Handles lvResultats.Resize AjusterColonnesResultats() End Sub Private Sub AjusterColonnesResultats() ' 19/03/2017 Attendre que la fenêtre soit initialisée (sinon sa taille n'est pas connue) If Not m_bInit Then Exit Sub ' 01/04/2017 If Me.WindowState = FormWindowState.Minimized Then Exit Sub ' Redimensionner la 1ère colonne pour pouvoir voir le chemin complet 'Me.lvResultats.Columns.Item(0).Width = Me.lvResultats.Width - 240 ' 16/10/2016 ' Redimensionner la 1ère colonne avec l'agrandissement de la zone complète Me.lvResultats.Columns.Item(0).Width += Me.lvResultats.Width - m_iMemTailleRech m_iMemTailleRech = Me.lvResultats.Width End Sub #End Region #Region "Gestion des menus contextuels" Private Sub cmdAjouterMenuCtx_Click(sender As Object, e As EventArgs) Handles cmdAjouterMenuCtx.Click AjouterMenuCtx() VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(sender As Object, e As EventArgs) Handles cmdEnleverMenuCtx.Click EnleverMenuCtx() VerifierMenuCtx() End Sub Private Sub VerifierMenuCtx() Dim sCleDescriptionCmd$ = sMenuCtx_TypeDossier & "\" & sDossierShell & "\" & sMenuCtx_CleCmdRechercher If bCleRegistreCRExiste(sCleDescriptionCmd) Then Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True Else Me.cmdAjouterMenuCtx.Enabled = True Me.cmdEnleverMenuCtx.Enabled = False End If End Sub Private Sub AjouterMenuCtx() If MsgBoxResult.Cancel = MsgBox("Ajouter le menu contextuel ?", MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sChemin$ = """%1""" If Not bAjouterMenuContextuel(sMenuCtx_TypeDossier, sMenuCtx_CleCmdRechercher, bPrompt, , sMenuCtx_CleCmdRechercherDescription, sCheminExe, sChemin) Then Exit Sub bAjouterMenuContextuel(sMenuCtx_TypeLecteur, sMenuCtx_CleCmdRechercher, bPrompt, , sMenuCtx_CleCmdRechercherDescription, sCheminExe, sChemin) End Sub Private Sub EnleverMenuCtx() If MsgBoxResult.Cancel = MsgBox("Enlever le menu contextuel ?", MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub If Not bAjouterMenuContextuel(sMenuCtx_TypeDossier, sMenuCtx_CleCmdRechercher, bEnlever:=True, bPrompt:=False) Then Exit Sub bAjouterMenuContextuel(sMenuCtx_TypeLecteur, sMenuCtx_CleCmdRechercher, bEnlever:=True, bPrompt:=False) End Sub Private Sub tbTailleMin_TextChanged(sender As Object, e As EventArgs) _ Handles tbTailleMin.TextChanged Dim lTailleMin& = 0 If Me.tbTailleMin.Text.Length > 0 Then lTailleMin = lConv(Me.tbTailleMin.Text) Dim sTailleMin$ = sFormaterTailleOctets(lTailleMin) Me.toolTip1.SetToolTip(Me.tbTailleMin, "Taille min. des fichiers : " & sTailleMin) End Sub Private Sub tbTailleMax_TextChanged(sender As Object, e As EventArgs) _ Handles tbTailleMax.TextChanged Dim lTailleMax& = 0 If Me.tbTailleMax.Text.Length > 0 Then lTailleMax = lConv(Me.tbTailleMax.Text) Dim sTailleMax$ = sFormaterTailleOctets(lTailleMax) Me.toolTip1.SetToolTip(Me.tbTailleMax, "Taille max. des fichiers : " & sTailleMax) End Sub ' 17/09/2022 Private Sub chkTailleMax_Click(sender As Object, e As EventArgs) Handles chkTailleMax.Click Me.tbTailleMax.Enabled = Me.chkTailleMax.Checked End Sub Private Sub chkTailleMin_Click(sender As Object, e As EventArgs) Handles chkTailleMin.Click Me.tbTailleMin.Enabled = Me.chkTailleMin.Checked End Sub Private Sub chkDateMax_Click(sender As Object, e As EventArgs) Handles chkDateMax.Click Me.dtpDateMax.Enabled = Me.chkDateMax.Checked End Sub Private Sub chkDateMin_Click(sender As Object, e As EventArgs) Handles chkDateMin.Click Me.dtpDateMin.Enabled = Me.chkDateMin.Checked End Sub #End Region End Class clsVBFileFind.vb Imports System.IO Imports System.Linq Imports System.Text ' Pour Encoding Public Class clsVBFileFind Private m_bDebugRecherche As Boolean = False Private m_bDebugTailleDossier As Boolean = False Private m_bDossierDebug As Boolean = False #Region "Interface" Public m_sMsgErr$ = "" Public m_lexErr As List(Of Exception) = New List(Of Exception) Public m_bSucces As Boolean = True ' Hashset des fichiers ou dossiers déjà trouvés, au cas où les filtres soient redondants Public m_hs As New HashSet(Of String) Public m_hsDossiers As New HashSet(Of String) ' Pour log : dossiers restants (non exclus) Public m_hsExclus As New HashSet(Of String) ' 25/10/2015 Fichiers ou dossiers exclus Public m_hsElementsTrouves As New HashSet(Of String) ' Fichiers ou dossiers qui matchent Public m_hsDossiersTrouves As New HashSet(Of String) ' Dossiers qui matchent Private m_hsbSousDossiers As HashSet(Of String) ' Clé : SousDossier : tous les sous-dossiers 'Private m_hsbSousDossiers2 As HashSet(Of String) ' Clé : SousDossier : tous les sous-dossiers ' Les dossiers exclus ne sont pas comptabilisés (car on compte la taille de chaque fichier ' de chaque dossier que l'on doit parcourir, pour mesurer la vitesse de recherche) Public m_dicoTaillesDossiers As Dictionary(Of String, Long) ' Clé : Dossier -> lTaille Public Enum TypeEncodage ASCII_Ou_Unicode = 0 ASCII = 1 Unicode = 2 Detecter = 3 ' 27/07/2024 End Enum #End Region #Region "Déclarations" ' Pour pouvoir détecter l'encodage, via l'option detectEncodingFromByteOrderMarks du StreamReader ' il faut lire le fichier depuis le StreamReader, et non plus directement depuis le FileStream Private Const bLectureDepuisFileStream As Boolean = False ' Ancienne technique Private m_msgDelegue As clsMsgDelegue 'Private m_queue As New Queue(Of String) ' Queue des répertoires à parcourir ' 05/03/2017 Queue.Contains bcp + rapide : Private m_queue As New HashQueue(Of String) ' Queue des répertoires à parcourir Private m_abTxtRech As Byte() = Nothing Private m_abTxtRechMin As Byte() = Nothing ' Minuscules Private m_abTxtRechUC As Byte() = Nothing ' Unicode Private m_abTxtRechMinUC As Byte() = Nothing ' Minuscules Private m_prm As clsPrm = Nothing Private m_bStop As Boolean = False Private m_iNbDossiersEmpiles% ' Tous les dossiers empilés Private m_iNbDossiersParcourus% ' Tous les dossiers en train d'être parcourus ou terminés ' Rencontrés : avant l'examen des conditions Private m_iNbFichiersOuDossiers% ' Tous les fichiers ou dossiers rencontrés Private m_iNbFichiers% ' Tous les fichiers rencontrés Private m_iNbDossiers% ' Tous les dossiers rencontrés ' Trouvés : qui matchent les conditions Private m_iNbFichiersOuDossiersTrouves% ' Tous les fichiers ou dossiers qui matchent Private m_iNbDossiersTrouves% ' Tous les dossiers qui matchent Private m_lNbOctetsLus& Private m_lNbOctetsCompares& Private m_lNbOctetsFichiers& Private m_lTailleMoyFichier& Private m_bAlerte As Boolean = False Private m_bPause As Boolean = False Property bPause() As Boolean Get bPause = m_bPause End Get Set(bVal As Boolean) m_bPause = bVal End Set End Property Public Class clsPrm ' Fields Public m_containingChecked As Boolean Public m_casseChecked As Boolean Public m_containingText$ Public m_iTypeEncodage As TypeEncodage ' 0, 1, 2 : 0 : les deux, 1 : ASCII, 2 : Unicode Public m_fileNames As List(Of String) Public m_fileNamesExcl As List(Of String) Public m_includeSubDirsChecked As Boolean Public m_newerThanChecked As Boolean Public m_newerThanDateTime As DateTime Public m_olderThanChecked As Boolean Public m_olderThanDateTime As DateTime ' 20/06/2022 Public m_greaterThanChecked As Boolean Public m_greaterThanSize As Long Public m_smallerThanChecked As Boolean Public m_smallerThanSize As Long Public m_searchDir$ Public m_bUseThread As Boolean ' Methods Public Sub New(searchDir$, includeSubDirsChecked As Boolean, fileNames As List(Of String), fileNamesExcl As List(Of String), newerThanChecked As Boolean, newerThanDateTime As DateTime, olderThanChecked As Boolean, olderThanDateTime As DateTime, greaterThanChecked As Boolean, greaterThanSize&, smallerThanChecked As Boolean, smallerThanSize&, containingChecked As Boolean, casseChecked As Boolean, containingText$, iTypeEncodage As clsVBFileFind.TypeEncodage, bUseThread As Boolean) Me.m_bUseThread = bUseThread Me.m_searchDir = searchDir Me.m_includeSubDirsChecked = includeSubDirsChecked Me.m_fileNames = fileNames Me.m_fileNamesExcl = fileNamesExcl Me.m_newerThanChecked = newerThanChecked Me.m_newerThanDateTime = newerThanDateTime Me.m_olderThanChecked = olderThanChecked Me.m_olderThanDateTime = olderThanDateTime ' 20/06/2022 Me.m_greaterThanChecked = greaterThanChecked Me.m_greaterThanSize = greaterThanSize Me.m_smallerThanChecked = smallerThanChecked Me.m_smallerThanSize = smallerThanSize Me.m_containingChecked = containingChecked Me.m_casseChecked = casseChecked Me.m_containingText = containingText Me.m_iTypeEncodage = iTypeEncodage End Sub End Class #End Region #Region "Interface : procédure" Public Sub cmdStart(prm As clsPrm, msgDelegue As clsMsgDelegue) Me.ResetVariables() Me.m_prm = prm Me.m_msgDelegue = msgDelegue Depart() ' Empilage niveau 1 End Sub Public Sub cmdStop() Me.m_bPause = False Me.m_bStop = True End Sub Private Sub Depart() If Me.m_prm.m_searchDir.Length < 3 OrElse Not Directory.Exists(Me.m_prm.m_searchDir) Then Me.m_bSucces = False Me.m_sMsgErr = "Impossible de trouver le dossier : " & Me.m_prm.m_searchDir GoTo Fin End If If Me.m_prm.m_containingChecked Then Try Dim sTxt$ = Me.m_prm.m_containingText Dim sTxtMin$ = sTxt.ToLower Me.m_abTxtRech = Encoding.ASCII.GetBytes(sTxt) Me.m_abTxtRechMin = Encoding.ASCII.GetBytes(sTxtMin) Me.m_abTxtRechUC = Encoding.Unicode.GetBytes(sTxt) Me.m_abTxtRechMinUC = Encoding.Unicode.GetBytes(sTxtMin) Catch ex As Exception Me.m_bSucces = False Me.m_sMsgErr = "Le texte ne peut pas être converti en octets : " & Me.m_prm.m_containingText End Try End If If Not Me.m_bSucces Then GoTo Fin EmpilerJob(Me.m_prm.m_searchDir) Fin: End Sub Private Sub EmpilerJob(sCheminDossier$) ' 02/10/2016 Si les filtres sont redondants, éviter d'empiler plusieurs fois les mêmes dossiers If Me.m_queue.Contains(sCheminDossier) Then Exit Sub Me.m_queue.Enqueue(sCheminDossier) Me.m_iNbDossiersEmpiles += 1 ' 25/09/2016 End Sub Public Function bResteJob() As Boolean If Me.m_queue.Count = 0 Then Return False Return True End Function Public Function sDepilerJob$() ' Dépiler 1 job Dim sDossier$ = DirectCast(Me.m_queue.Dequeue, String) Return sDossier End Function Public Sub LireInfos(ByRef iNbFichiersOuDossiersTrouves%, ByRef iNbFichiersOuDossiers%, ByRef lNbOctetsLus&, ByRef lNbOctetsCompares&, ByRef lNbOctetsFichiers&, ByRef lTailleMoyFichier&, ByRef iNbDossiersParcourus%, ByRef iNbDossiers%) iNbFichiersOuDossiersTrouves = Me.m_iNbFichiersOuDossiersTrouves iNbFichiersOuDossiers = Me.m_iNbFichiersOuDossiers lNbOctetsLus = Me.m_lNbOctetsLus lNbOctetsCompares = Me.m_lNbOctetsCompares lNbOctetsFichiers = Me.m_lNbOctetsFichiers lTailleMoyFichier = Me.m_lTailleMoyFichier iNbDossiersParcourus = Me.m_iNbDossiersParcourus ' 25/09/2016 'iNbDossiers = Me.m_iNbDossiers iNbDossiers = Me.m_iNbDossiersEmpiles ' 25/09/2016 End Sub #End Region #Region "Traitements" Private Sub ResetVariables() Me.m_bPause = False Me.m_bStop = False Me.m_bSucces = True Me.m_sMsgErr = "" Me.m_prm = Nothing Me.m_abTxtRech = Nothing Me.m_abTxtRechMin = Nothing Me.m_bAlerte = False Me.m_iNbFichiersOuDossiersTrouves = 0 Me.m_lNbOctetsLus = 0 Me.m_lNbOctetsCompares = 0 Me.m_lNbOctetsFichiers = 0 Me.m_lTailleMoyFichier = 0 Me.m_iNbDossiersTrouves = 0 Me.m_iNbFichiers = 0 Me.m_iNbDossiers = 0 Me.m_iNbDossiersEmpiles = 0 Me.m_iNbDossiersParcourus = 0 Me.m_iNbFichiersOuDossiers = 0 Me.m_lexErr = New List(Of Exception) Me.m_hs = New HashSet(Of String) Me.m_hsDossiers = New HashSet(Of String) Me.m_hsExclus = New HashSet(Of String) Me.m_queue = New HashQueue(Of String) Me.m_dicoTaillesDossiers = New Dictionary(Of String, Long) Me.m_hsbSousDossiers = New HashSet(Of String) 'Me.m_hsbSousDossiers2 = New HashSet(Of String) Me.m_hsElementsTrouves = New HashSet(Of String) Me.m_hsDossiersTrouves = New HashSet(Of String) End Sub Private Sub VerifierPause() Do While Me.m_bPause Attendre(100) TraiterMsgSysteme_DoEvents() Loop End Sub Public Sub ChercherArbo(dirInfo As DirectoryInfo, bExclusion As Boolean) If Me.m_bStop Then Return Dim iLongDossier% = dirInfo.FullName.Length If iLongDossier >= 248 Then Return ' 25/09/2016 Const iLongMaxCheminComplet% = 260 - 1 ' La longueur du chemin du dossier doit être < à 248 car. et les fichiers < 260 car. ' sinon on obtient l'exception suivante lorsque l'on fait dirInfo.GetFileSystemInfos : ' HResult=-2147024690 ' Le chemin d'accès spécifié, le nom de fichier ou les deux sont trop longs. ' Le nom de fichier qualifié complet doit comprendre moins de 260 caractères ' et le nom du répertoire moins de 248 caractères. If Not bExclusion Then Me.m_iNbDossiersParcourus += 1 End If Dim lTailleOctetsDossier& = 0 Try Dim lstFiltre As List(Of String) = Me.m_prm.m_fileNames ' Note : Dans la fonction DepilerJobInterne, s'il y a une exclusion ' alors on appelle deux fois ChercherArbo, avec et sans exclusion ' En mode exclusion, on se contente de construire m_hsExclus ' pour pouvoir filtrer ensuite le mode sans exclusion ' Whismeril a proposé en 2017 d'utiliser plutôt une requête linq pour les exclusions : ' Dim exclusions() As String = { "pas ca", "niCeluilà" } ' Dim resultats() As String = ( ' From f In Directory.GetFiles("C:\Temp", "*a*.txt") ' Where (Not exclusions.Any(Function(ex) ExclureFichier(ex, f))) ' Select f).ToArray() ' https://codes-sources.commentcamarche.net/source/52496-vbfilefind-recherche-de-fichiers-pour-remplacer-celle-de-windows ' https://codes-sources.commentcamarche.net/profile/user/Whismeril ' Mais du coup, il faudrait réécrire en partie le code actuel, car il est ' basé sur dirInfo.GetFileSystemInfos et non pas sur Directory.GetFiles If bExclusion Then lstFiltre = Me.m_prm.m_fileNamesExcl For Each fileName As String In lstFiltre Dim iLongFichier% = fileName.Length Dim iLongTot% = iLongDossier + iLongFichier + 1 ' +1 pour le \ If iLongTot > iLongMaxCheminComplet Then Continue For ' 25/09/2016 Dim afsi As FileSystemInfo() = dirInfo.GetFileSystemInfos(fileName) For Each fsifileInfo As FileSystemInfo In afsi ' S'il n'y a pas de thread on doit traiter les événements If Not Me.m_prm.m_bUseThread Then TraiterMsgSysteme_DoEvents() If Me.m_bStop Then Return VerifierPause() Dim sCheminComplet$ = fsifileInfo.FullName ' 25/10/2015 D'abord on recherche les fichiers exclus du dossier ' et ensuite on exclut ces fichiers du dossier If bExclusion Then If Not Me.m_hsExclus.Contains(sCheminComplet) Then _ Me.m_hsExclus.Add(sCheminComplet) Continue For Else If Me.m_hsExclus.Contains(sCheminComplet) Then Continue For End If ' 06/07/2014 N'ajouter qu'une fois chaque élément, si les filtres sont redondants If Me.m_hs.Contains(sCheminComplet) Then Continue For Me.m_hs.Add(sCheminComplet) Me.m_iNbFichiersOuDossiers += 1 Dim bFichier As Boolean = False Dim lTailleFichier& = 0 ' 20/06/2022 If TypeOf (fsifileInfo) Is FileInfo Then ' Fichier (et non Dossier) bFichier = True Dim fi As FileInfo = DirectCast(fsifileInfo, FileInfo) lTailleFichier = fi.Length Me.m_iNbFichiers += 1 Me.m_lNbOctetsFichiers += lTailleFichier Me.m_lTailleMoyFichier = Me.m_lNbOctetsFichiers \ Me.m_iNbFichiers If m_bDebugTailleDossier AndAlso m_bDossierDebug Then Debug.WriteLine("Fichier : " & sCheminComplet & " : " & lTailleFichier & " octets") Debug.WriteLine("Dossier avant : " & lTailleOctetsDossier) End If lTailleOctetsDossier += lTailleFichier If m_bDebugTailleDossier AndAlso m_bDossierDebug Then Debug.WriteLine("Dossier après : " & lTailleOctetsDossier) End If Else ' On a déjà vérifié les doublons avec m_hs 'If Not Me.m_hsDossiers.Contains(sCheminComplet) Then Me.m_hsDossiers.Add(sCheminComplet) Me.m_iNbDossiers += 1 'End If ' 24/09/2022 Compter la taille des fichiers inclus dans le dossier If Me.m_prm.m_greaterThanChecked OrElse Me.m_prm.m_smallerThanChecked Then ' Cette fois la taille est juste et correspond à l'explorateur de fichier Dim dirInfo2 As New DirectoryInfo(fsifileInfo.FullName) lTailleFichier = dirInfo2.EnumerateFiles("*.*", SearchOption.AllDirectories).Sum(Function(file) file.Length) End If End If ' On a déjà vérifié les doublons avec m_hs 'If Me.m_hsElementsTrouves.Contains(sCheminComplet) Then Continue For If bElementCorrespondant(fsifileInfo, bFichier, lTailleFichier) Then Me.m_iNbFichiersOuDossiersTrouves += 1 Me.m_hsElementsTrouves.Add(sCheminComplet) If Not bFichier Then ' Pour un dossier, on n'a vérifié que la date, le cas échéant ' et la taille aussi maintenant 18/09/2022 Me.m_iNbDossiersTrouves += 1 Me.m_hsDossiersTrouves.Add(sCheminComplet) m_bDossierDebug = False If sCheminComplet = "" Then m_bDossierDebug = True If m_bDebugTailleDossier AndAlso m_bDossierDebug Then Debug.WriteLine("Dossier : " & sCheminComplet & " : " & lTailleFichier & " octets") Debug.WriteLine("Dossier avant : " & lTailleOctetsDossier) End If lTailleOctetsDossier += lTailleFichier If m_bDebugTailleDossier AndAlso m_bDossierDebug Then Debug.WriteLine("Dossier après : " & lTailleOctetsDossier) End If End If m_msgDelegue.AfficherFSIEnCours(fsifileInfo) End If Next Next If Not bExclusion Then ' 01/10/2016 On n'a pas la taille dans ce cas ' Màj de la taille du dossier Dim sCle$ = dirInfo.FullName If Not m_dicoTaillesDossiers.ContainsKey(sCle) Then _ m_dicoTaillesDossiers.Add(sCle, lTailleOctetsDossier) End If If Me.m_prm.m_includeSubDirsChecked Then Dim subDirInfos As DirectoryInfo() = dirInfo.GetDirectories For Each subDirInfo As DirectoryInfo In subDirInfos ' S'il n'y a pas de thread on doit traiter les événements If Not Me.m_prm.m_bUseThread Then TraiterMsgSysteme_DoEvents() If Me.m_bStop Then Return VerifierPause() ' Pour parcourir à la fin les sous-dossiers pour màj ' la taille de leur dossier parent If Not Me.m_hsbSousDossiers.Contains(subDirInfo.FullName) Then _ Me.m_hsbSousDossiers.Add(subDirInfo.FullName) ' 25/10/2015 Exclure les dossiers correspondants au filtre d'exclusion If Me.m_hsExclus.Contains(subDirInfo.FullName) Then Continue For EmpilerJob(subDirInfo.FullName) ' Appel récursif asynchrone Next End If Catch ex As Exception ' Exemple d'erreur : le dossier n'est pas accessible Me.m_lexErr.Add(ex) End Try End Sub Public Sub CalculerTaillesDossiers() ' Calculer la taille totale des dossiers avec leur sous-dossiers ' (pas seulement la taille des dossiers qui matchent) For Each sSousDossier As String In Me.m_hsbSousDossiers ' Les dossiers exclus ne sont pas comptabilisés If Not m_dicoTaillesDossiers.ContainsKey(sSousDossier) Then 'Debug.WriteLine("Dossier non comptab.: " & sSousDossier) Continue For End If Dim lTailleSousDossier& = m_dicoTaillesDossiers(sSousDossier) If lTailleSousDossier = 0 Then 'Debug.WriteLine("Sous-dossier vide : " & sSousDossier) Continue For End If Dim sDossierParent$ = IO.Path.GetDirectoryName(sSousDossier) Dim sCle$ = sDossierParent ' Le dossier parent racine peut être absent If Not m_dicoTaillesDossiers.ContainsKey(sCle) Then Continue For Dim bDebug1 As Boolean = False If m_bDebugTailleDossier Then Debug.WriteLine("Dossier : " & sSousDossier) bDebug1 = True End If Dim lTailleParent& = m_dicoTaillesDossiers(sCle) Dim lTailleParentNouv& = lTailleParent + lTailleSousDossier m_dicoTaillesDossiers.Remove(sCle) m_dicoTaillesDossiers.Add(sCle, lTailleParentNouv) If bDebug1 Then Debug.WriteLine("Cumul dossier : " & sDossierParent & " : " & lTailleParent & " + " & lTailleSousDossier & " -> " & lTailleParentNouv & " : " & sSousDossier) Next End Sub Private Function bElementCorrespondant(fsi As FileSystemInfo, bFichier As Boolean, lTailleFichier&) As Boolean Dim bOk As Boolean = True If bOk AndAlso Me.m_prm.m_newerThanChecked Then bOk = (fsi.LastWriteTime >= Me.m_prm.m_newerThanDateTime) End If If bOk AndAlso Me.m_prm.m_olderThanChecked Then bOk = (fsi.LastWriteTime <= Me.m_prm.m_olderThanDateTime) End If ' 20/06/2022 Faire un booléen pour filtrer aussi la taille des dossiers ? ' (le calcul de la taille du dossier risque de ralentir) ' Filtrer que les fichiers : If bOk AndAlso bFichier AndAlso Me.m_prm.m_greaterThanChecked Then bOk = (lTailleFichier >= Me.m_prm.m_greaterThanSize) End If If bOk AndAlso bFichier AndAlso Me.m_prm.m_smallerThanChecked Then bOk = (lTailleFichier <= Me.m_prm.m_smallerThanSize) End If ' Filtrer les fichiers et dossiers : If bOk AndAlso Not bFichier AndAlso Me.m_prm.m_greaterThanChecked Then bOk = (lTailleFichier >= Me.m_prm.m_greaterThanSize) End If If bOk AndAlso Not bFichier AndAlso Me.m_prm.m_smallerThanChecked Then bOk = (lTailleFichier <= Me.m_prm.m_smallerThanSize) End If If bOk AndAlso Me.m_prm.m_containingChecked Then bOk = False ' Si l'élément est un dossier, alors poursuivre If Not bFichier Then GoTo Suite ' C'est un fichier : lancer une recherche de son contenu Dim abTxtRech As Byte() = Nothing Dim abTxtRechMin As Byte() = Nothing Dim abTxtRechUc As Byte() = Nothing Dim abTxtRechMinUc As Byte() = Nothing ' Recherches sensibles à la casse (minuscules/majuscules) Dim bDetecterEncodage As Boolean = False If Me.m_prm.m_iTypeEncodage = TypeEncodage.ASCII Then abTxtRech = Me.m_abTxtRech ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.Unicode Then abTxtRechUc = Me.m_abTxtRechUC ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.ASCII_Ou_Unicode Then ' Les 2 abTxtRech = Me.m_abTxtRech abTxtRechUc = Me.m_abTxtRechUC ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.Detecter Then abTxtRech = Me.m_abTxtRech abTxtRechUc = Me.m_abTxtRechUC bDetecterEncodage = True ' 27/07/2024 End If ' Recherches insensibles à la casse If Not Me.m_prm.m_casseChecked Then If Me.m_prm.m_iTypeEncodage = TypeEncodage.ASCII Then abTxtRechMin = Me.m_abTxtRechMin ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.Unicode Then abTxtRechMinUc = Me.m_abTxtRechMinUC ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.ASCII_Ou_Unicode Then ' Les 2 abTxtRechMin = Me.m_abTxtRechMin abTxtRechMinUc = Me.m_abTxtRechMinUC ElseIf Me.m_prm.m_iTypeEncodage = TypeEncodage.Detecter Then abTxtRech = Me.m_abTxtRechMin abTxtRechUc = Me.m_abTxtRechMinUC bDetecterEncodage = True ' 27/07/2024 End If End If If bLectureDepuisFileStream Then ' Ancienne technique : pas d'option de détection de l'encodage bOk = bFichierContientOccFileStream(fsi.FullName, abTxtRech, abTxtRechMin, abTxtRechUc, abTxtRechMinUc) Else ' 16/04/2023 Même code, mais en utilisant un StreamReader cette fois : pas de différence, ' mais on peut maintenant demander à détecter l'encodage, via l'option ' detectEncodingFromByteOrderMarks de StreamReader bOk = bFichierContientOccStreamReader(fsi.FullName, abTxtRech, abTxtRechMin, abTxtRechUc, abTxtRechMinUc, bDetecterEncodage) End If End If Suite: Return bOk End Function Private Function bFichierContientOccFileStream(sChemin$, abTxtRech As Byte(), abTxtRechMin As Byte(), abTxtRechUc As Byte(), abTxtRechMinUc As Byte()) As Boolean Dim bContient As Boolean = False Dim iTailleBloc% = 16384 ' 4096 Dim iLongRech% = 0 Dim iLongRechUc% = 0 Dim bRech As Boolean = True If IsNothing(abTxtRech) Then bRech = False If bRech Then iLongRech = abTxtRech.Length Dim bRechUc As Boolean = True If IsNothing(abTxtRechUc) Then bRechUc = False If bRechUc Then iLongRechUc = abTxtRechUc.Length Dim bRechMin As Boolean = True If IsNothing(abTxtRechMin) Then bRechMin = False If bRechMin Then Dim iLongRechMin% = abTxtRechMin.Length If iLongRechMin <> iLongRech Then Debug.WriteLine("!") If bDebug Then Stop End If End If Dim bRechMinUc As Boolean = True If IsNothing(abTxtRechMinUc) Then bRechMinUc = False If bRechMinUc Then Dim iLongRechMinUc% = abTxtRechMinUc.Length If iLongRechMinUc <> iLongRechUc Then Debug.WriteLine("!") If bDebug Then Stop End If End If If Not bRech And bRechUc Then iLongRech = iLongRechUc ' Si le texte a chercher est vide, alors tous les fichiers correspondent If iLongRech = 0 Then GoTo Fin ' Si le nbre d'octets à rechercher est > à la taille du bloc, alors ' cela veut dire que l'on cherche un texte de très grande taille : idiot ! If iLongRech > iTailleBloc Then If Not Me.m_bAlerte Then _ MsgBox("La taille du tampon de recherche est insuffisante : " & iTailleBloc & "<" & iLongRech & " (longueur de la chaîne à rechercher)", MsgBoxStyle.Critical) Me.m_bAlerte = True GoTo Fin End If Dim iLongBloc% = iLongRech - 1 + iTailleBloc - 1 Dim abBloc As Byte() = New Byte(iLongBloc) {} Dim acBloc As Char() = Nothing Dim sr As StreamReader = Nothing Try Using fs As New FileStream(sChemin, FileMode.Open, FileAccess.Read) If m_bDebugRecherche Then Debug.WriteLine("\nFichier : " & IO.Path.GetFileName(sChemin) & "\n") RechercheOcc( fs, sr, iLongRech, iTailleBloc, bRech, bRechUc, bRechMin, bRechMinUc, abTxtRech, abTxtRechMin, abTxtRechUc, abTxtRechMinUc, acBloc, abBloc, bContient, bReadFileStream:=True) End Using 'fs.Close() Catch ex As Exception Me.m_lexErr.Add(ex) End Try Fin: Return bContient End Function Private Function abConvMin(enc As Encoding, abBloc As Byte(), ByRef bEchec As Boolean) As Byte() ' Convertir un tableau d'octets en minuscules selon l'encodage demandé ' (en supposant que les octets forment un texte, ce qui n'est que pur hypothèse) ' On pourrait simplifier (sans vérification) en : ' enc.GetBytes(enc.GetString(abBloc).ToLower) bEchec = False Dim sChaine$ = enc.GetString(abBloc) Dim sChaineMin$ = sChaine.ToLower abConvMin = enc.GetBytes(sChaineMin) ' Vérification Dim iLenSrc% = abBloc.Length Verifier: Dim iLenMin% = abConvMin.Length If iLenMin < iLenSrc Then Debug.WriteLine("!") If bDebug Then Stop bEchec = True End If If iLenMin > iLenSrc And Not bEchec Then ' Si la longueur en minuscule n'est plus la même, ' on peut quand même trouver l'occurrence : poursuivre la recherche bEchec = True ReDim Preserve abConvMin(0 To iLenSrc - 1) GoTo Verifier End If End Function Private Function bContientTxt(iPosFin%, iLongRech%, abBloc As Byte(), abTxtRech As Byte(), bRechercheUnicode As Boolean) As Boolean For i As Integer = 0 To iPosFin - 1 Dim j% = 0 Do While j < iLongRech If abBloc(i + j) <> abTxtRech(j) Then Exit Do j += 1 Loop Me.m_lNbOctetsCompares += j + 1 If j = iLongRech Then Return True Next i Return False End Function ' Même code, mais en utilisant un streamreader cette fois : pas de différence, mais on peut détecter l'encodage ! Private Function bFichierContientOccStreamReader(sChemin$, abTxtRech As Byte(), abTxtRechMin As Byte(), abTxtRechUc As Byte(), abTxtRechMinUc As Byte(), bDetecterEncodage As Boolean) As Boolean Dim bContient As Boolean = False Dim iTailleBloc% = 16384 ' 4096 Dim iLongRech% = 0 Dim iLongRechUc% = 0 Dim bRech As Boolean = True If IsNothing(abTxtRech) Then bRech = False If bRech Then iLongRech = abTxtRech.Length Dim bRechUc As Boolean = True If IsNothing(abTxtRechUc) Then bRechUc = False If bRechUc Then iLongRechUc = abTxtRechUc.Length Dim bRechMin As Boolean = True If IsNothing(abTxtRechMin) Then bRechMin = False If bRechMin Then Dim iLongRechMin% = abTxtRechMin.Length If iLongRechMin <> iLongRech Then Debug.WriteLine("!") If bDebug Then Stop End If End If Dim bRechMinUc As Boolean = True If IsNothing(abTxtRechMinUc) Then bRechMinUc = False If bRechMinUc Then Dim iLongRechMinUc% = abTxtRechMinUc.Length If iLongRechMinUc <> iLongRechUc Then Debug.WriteLine("!") If bDebug Then Stop End If End If If Not bRech And bRechUc Then iLongRech = iLongRechUc ' Si le texte a chercher est vide, alors tous les fichiers correspondent If iLongRech = 0 Then GoTo Fin ' Si le nbre d'octets à rechercher est > à la taille du bloc, alors ' cela veut dire que l'on cherche un texte de très grande taille : idiot ! If iLongRech > iTailleBloc Then If Not Me.m_bAlerte Then _ MsgBox("La taille du tampon de recherche est insuffisante : " & iTailleBloc & "<" & iLongRech & " (longueur de la chaîne à rechercher)", MsgBoxStyle.Critical) Me.m_bAlerte = True GoTo Fin End If Dim iLongBloc% = iLongRech - 1 + iTailleBloc - 1 Dim acBloc As Char() = New Char(iLongBloc) {} Dim abBloc As Byte() = Nothing Try Dim encodage As Encoding If bRechUc OrElse bRechMinUc Then encodage = Encoding.Unicode Else encodage = Encoding.ASCII End If Using fs As New FileStream(sChemin, FileMode.Open, FileAccess.Read) If bDetecterEncodage Then If m_bDebugRecherche Then Debug.WriteLine("\nFichier : " & IO.Path.GetFileName(sChemin) & "\n") Using sr As New StreamReader(fs, detectEncodingFromByteOrderMarks:=bDetecterEncodage) RechercheOcc( fs, sr, iLongRech, iTailleBloc, bRech, bRechUc, bRechMin, bRechMinUc, abTxtRech, abTxtRechMin, abTxtRechUc, abTxtRechMinUc, acBloc, abBloc, bContient, bReadFileStream:=False) End Using Else Using sr As New StreamReader(fs, encodage) RechercheOcc( fs, sr, iLongRech, iTailleBloc, bRech, bRechUc, bRechMin, bRechMinUc, abTxtRech, abTxtRechMin, abTxtRechUc, abTxtRechMinUc, acBloc, abBloc, bContient, bReadFileStream:=False) End Using End If End Using Catch ex As Exception Me.m_lexErr.Add(ex) End Try Fin: Return bContient End Function Private Sub RechercheOcc( fs As FileStream, sr As StreamReader, iLongRech%, iTailleBloc%, bRech As Boolean, bRechUc As Boolean, bRechMin As Boolean, bRechMinUc As Boolean, abTxtRech As Byte(), abTxtRechMin As Byte(), abTxtRechUc As Byte(), abTxtRechMinUc As Byte(), acBloc As Char(), abBloc As Byte(), ByRef bContient As Boolean, bReadFileStream As Boolean) Dim iNbOctetsLus% If bReadFileStream Then iNbOctetsLus = fs.Read(abBloc, 0, abBloc.Length) Else iNbOctetsLus = sr.Read(acBloc, 0, acBloc.Length) If m_bDebugRecherche Then Dim encodage As Encoding = sr.CurrentEncoding Debug.WriteLine("Encodage détecté : " & encodage.ToString) End If End If Me.m_lNbOctetsLus += iNbOctetsLus Boucle: Dim iPosFin% = iNbOctetsLus - iLongRech + 1 If bRech Then If bReadFileStream Then bContient = bContientTxt(iPosFin, iLongRech, abBloc, abTxtRech, bRechercheUnicode:=False) Else bContient = bContientTxt(iPosFin, iLongRech, acBloc, abTxtRech, bRechercheUnicode:=False) End If If bContient Then Exit Sub End If If bRechUc Then If bReadFileStream Then bContient = bContientTxt(iPosFin, iLongRech, abBloc, abTxtRechUc, bRechercheUnicode:=True) Else bContient = bContientTxt(iPosFin, iLongRech, acBloc, abTxtRechUc, bRechercheUnicode:=True) End If If bContient Then Exit Sub End If If bRechMin Then ' Rechercher aussi en minuscules ' Il faut aussi que abBloc soit ToLower, pour cela il faut l'encodage Dim bEchec As Boolean Dim abMin As Byte() If bReadFileStream Then abMin = abConvMin(Encoding.ASCII, abBloc, bEchec) Else abMin = abConvMin(Encoding.ASCII, acBloc, bEchec) End If bContient = bContientTxt(iPosFin, iLongRech, abMin, abTxtRechMin, bRechercheUnicode:=False) If bContient Then Exit Sub End If If bRechMinUc Then ' Rechercher aussi en minuscules Dim bEchec As Boolean Dim abMin As Byte() If bReadFileStream Then abMin = abConvMin(Encoding.Unicode, abBloc, bEchec) Else abMin = abConvMin(Encoding.Unicode, acBloc, bEchec) End If bContient = bContientTxt(iPosFin, iLongRech, abMin, abTxtRechMinUc, bRechercheUnicode:=True) ' Si la longueur en minuscule n'est plus la même (bEchec), ' on peut quand même trouver l'occurrence : poursuivre la recherche If bContient Then Exit Sub End If If fs.Position >= fs.Length Then Exit Sub For i As Integer = 0 To iLongRech - 1 - 1 acBloc(i) = acBloc(iTailleBloc + i) Next i Dim iNbOctetsLus0% If bReadFileStream Then iNbOctetsLus0 = fs.Read(abBloc, iLongRech - 1, iTailleBloc) Else iNbOctetsLus0 = sr.Read(acBloc, iLongRech - 1, iTailleBloc) End If Me.m_lNbOctetsLus += iNbOctetsLus0 iNbOctetsLus = iLongRech - 1 + iNbOctetsLus0 ' Si on enlève le thread alors traiter les événements TraiterMsgSysteme_DoEvents() VerifierPause() If Not Me.m_bStop Then GoTo Boucle End Sub Private Function abConvMin(enc As Encoding, acBloc As Char(), ByRef bEchec As Boolean) As Byte() ' Convertir un tableau d'octets en minuscules selon l'encodage demandé ' (en supposant que les octets forment un texte, ce qui n'est que pur hypothèse) ' On pourrait simplifier (sans vérification) en : ' enc.GetBytes(enc.GetString(abBloc).ToLower) bEchec = False Dim abBloc As Byte() = New Byte(acBloc.Length) {} For i As Integer = 0 To acBloc.Length - 1 Dim c As Char = acBloc(i) Dim iAscW% = Microsoft.VisualBasic.AscW(c) If iAscW > Byte.MaxValue Then Continue For ' 16/04/2023 Dim b As Byte = CByte(iAscW) abBloc(i) = b Next Dim sChaine$ = enc.GetString(abBloc) Dim sChaineMin$ = sChaine.ToLower abConvMin = enc.GetBytes(sChaineMin) ' Vérification Dim iLenSrc% = acBloc.Length Verifier: Dim iLenMin% = abConvMin.Length If iLenMin < iLenSrc Then Debug.WriteLine("!") If bDebug Then Stop bEchec = True End If If iLenMin > iLenSrc And Not bEchec Then ' Si la longueur en minuscule n'est plus la même, ' on peut quand même trouver l'occurrence : poursuivre la recherche bEchec = True ReDim Preserve abConvMin(0 To iLenSrc - 1) GoTo Verifier End If End Function Private Function bContientTxt(iPosFin%, iLongRech%, acBloc As Char(), abTxtRech As Byte(), bRechercheUnicode As Boolean) As Boolean If m_bDebugRecherche Then Debug.WriteLine("") If bRechercheUnicode Then Debug.WriteLine("Recherche Unicode : ") Else Debug.WriteLine("Recherche ASCII : ") End If Dim subArray As Char() ReDim subArray(iPosFin + 1) Array.Copy(acBloc, 0, subArray, 0, subArray.Length) Dim texteDetect$ = New String(subArray) Debug.WriteLine("Texte recherché : " & texteDetect & " : ") Dim texteRechercheUTF8$ = Encoding.UTF8.GetString(abTxtRech) Debug.WriteLine("Test UTF8 : " & texteRechercheUTF8 & " : ") Dim texteRechercheUc$ = Encoding.Unicode.GetString(abTxtRech) Debug.WriteLine("Test Unicode : " & texteRechercheUc & " : ") For i As Integer = 0 To abTxtRech.GetUpperBound(0) Dim c As Byte = abTxtRech(i) Debug.Write(c & ", ") Next Debug.WriteLine(" -> ") End If For i As Integer = 0 To iPosFin - 1 Dim j% = 0 Do While j < iLongRech Dim c As Char = acBloc(i + j) Dim b As Byte = abTxtRech(j) Dim ci% = Asc(c) If m_bDebugRecherche AndAlso i < 10 Then Debug.Write(ci & ", ") If ci <> b Then Exit Do j += 1 Loop Me.m_lNbOctetsCompares += j + 1 If j = iLongRech Then Return True Next i Return False End Function #End Region End Class modDepart.vb Module modDepart #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If Public ReadOnly sNomAppli$ = My.Application.Info.Title Public ReadOnly sTitreMsg$ = sNomAppli Private Const sDateVersionVBFileFind$ = "03/08/2024" Public Const sDateVersionAppli$ = sDateVersionVBFileFind Public ReadOnly sVersionAppli$ = My.Application.Info.Version.Major & "." & My.Application.Info.Version.Minor & My.Application.Info.Version.Build Public m_sTitreMsg$ = sNomAppli Public Sub DefinirTitreApplication(sTitreMsg As String) m_sTitreMsg = sTitreMsg End Sub Public Sub Main() ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE ' Sinon, ce n'est pas pratique de retrouver la ligne du bug : ' il faut cocher Thrown dans le menu Debug:Exception... pour les 2 lignes ' (dans ce cas, il peut y avoir beaucoup d'interruptions selon la logique ' de programmation : mieux vaut prévenir les erreurs que de les traiter) ' C'était plus simple avec On Error Goto X, car on pouvait ' désactiver la gestion d'erreur avec une simple constante bTrapErr. If bDebug Then Depart() : Exit Sub ' Attention : En mode Release il faut un Try Catch ici ' car sinon il n'y a pas de gestion d'erreur ! ' (.Net renvoie un message d'erreur équivalent ' à un plantage complet sans explication) Try Depart() Catch ex As Exception AfficherMsgErreur2(ex, "Main " & sTitreMsg) End Try End Sub Private Sub Depart() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command Dim asArgs$() = asArgLigneCmd(sArg0) Dim sCheminDossier$ = "" If (sArg0.Length <> 0) Then Dim iNbArguments% = UBound(asArgs) + 1 If iNbArguments = 1 Then sCheminDossier = asArgs(0) End If Dim frm As New frmVBFileFind frm.m_sCheminDossier = sCheminDossier Application.Run(frm) End Sub End Module modUtil.vb Imports System.Text ' Pour StringBuilder Module modUtilitaires ' Module de fonctions utilitaires Public Sub AfficherMsgErreur2(ByRef Ex As Exception, Optional sTitreFct$ = "", Optional sInfo$ = "", Optional sDetailMsgErr$ = "", Optional bCopierMsgPressePapier As Boolean = True, Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", bCopierMsgPressePapier:=False) End Try End Sub Public Sub Attendre(Optional iMilliSec% = 200) Threading.Thread.Sleep(iMilliSec) End Sub Public Sub TraiterMsgSysteme_DoEvents() 'Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire 'Catch 'End Try End Sub Public Function iConv%(sVal$, Optional iValDef% = 0) If String.IsNullOrEmpty(sVal) Then Return iValDef Dim iVal% If Integer.TryParse(sVal, iVal) Then Return iVal Else Return iValDef End If End Function Public Function lConv&(sVal$, Optional lValDef& = 0) If String.IsNullOrEmpty(sVal) Then Return lValDef Dim lVal& If Long.TryParse(sVal, lVal) Then Return lVal Else Return lValDef End If End Function End Module clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Imports System.IO Public Class clsTickEventArgs : Inherits EventArgs ' Classe pour l'événement Tick : avancement d'une unité de temps : TIC-TAC ' utile pour mettre à jour l'heure en cours, ou pour scruter une annulation Public Sub New() End Sub End Class Public Class clsMsgEventArgs : Inherits EventArgs ' Classe pour l'événement Message Private m_sMsg$ = "" 'Nothing Public Sub New(sMsg$) 'If sMsg Is Nothing Then Throw New NullReferenceException If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsFECEventArgs : Inherits EventArgs ' Classe pour l'événement Fichier En Cours (FEC) Private m_iNumFichierEnCours% = 0 Public Sub New(iNumFichierEnCours%) Me.m_iNumFichierEnCours = iNumFichierEnCours End Sub Public ReadOnly Property iNumFichierEnCours%() Get Return Me.m_iNumFichierEnCours End Get End Property End Class Public Class clsFSIEventArgs : Inherits EventArgs ' Classe pour l'événement FileSystemInfo Private m_fsi As FileSystemInfo Public ReadOnly Property fsi() As FileSystemInfo Get Return Me.m_fsi End Get End Property Public Sub New(fsi As FileSystemInfo) Me.m_fsi = fsi End Sub End Class Public Class clsAvancementEventArgs : Inherits EventArgs ' Classe pour l'événement Avancement Private m_sMsg$ = "" Private m_lAvancement& = 0 Public Sub New(sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public Sub New(lAvancement&) Me.m_lAvancement = lAvancement End Sub Public Sub New(lAvancement&, sMsg$) Me.m_lAvancement = lAvancement If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property Public ReadOnly Property lAvancement&() Get Return Me.m_lAvancement End Get End Property End Class Public Class clsSablierEventArgs : Inherits EventArgs ' Classe pour l'événement Sablier Private m_bDesactiver As Boolean = False Public Sub New(bDesactiver As Boolean) Me.m_bDesactiver = bDesactiver End Sub Public ReadOnly Property bDesactiver() As Boolean Get Return Me.m_bDesactiver End Get End Property End Class Public Class clsMsgDelegue ' Classe de gestion des messages via des délégués 'Const bDoEvents As Boolean = False ' 16/10/2016 Pas de différence constatée ! Const bDoEvents As Boolean = True ' 04/02/2018 Il faut activer pour gérer l'annulation 'Private Delegate Sub GestEvTick(sender As Object, e As clsTickEventArgs) 'Public Event EvTick As GestEvTick Public Event EvTick As EventHandler(Of clsTickEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherMessage(sender As Object, e As clsMsgEventArgs) 'Public Event EvAfficherMessage As GestEvAfficherMessage Public Event EvAfficherMessage As EventHandler(Of clsMsgEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherFEC(sender As Object, e As clsFECEventArgs) 'Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC Public Event EvAfficherNumFichierEnCours As EventHandler(Of clsFECEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherFSI(sender As Object, e As clsFSIEventArgs) 'Public Event EvAfficherFSIEnCours As GestEvAfficherFSI Public Event EvAfficherFSIEnCours As EventHandler(Of clsFSIEventArgs) ' CA1003 'Private Delegate Sub GestEvAfficherAvancement(sender As Object, e As clsAvancementEventArgs) 'Public Event EvAfficherAvancement As GestEvAfficherAvancement Public Event EvAfficherAvancement As EventHandler(Of clsAvancementEventArgs) ' CA1003 'Private Delegate Sub GestEvSablier(sender As Object, e As clsSablierEventArgs) 'Public Event EvSablier As GestEvSablier Public Event EvSablier As EventHandler(Of clsSablierEventArgs) ' CA1003 Public m_bAnnuler As Boolean Public m_bErr As Boolean ' 21/03/2016 Public Sub New() End Sub Public Sub AfficherMsg(sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFichierEnCours(iNumFichierEnCours%) Dim e As New clsFECEventArgs(iNumFichierEnCours) RaiseEvent EvAfficherNumFichierEnCours(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFSIEnCours(fsi As FileSystemInfo) Dim e As New clsFSIEventArgs(fsi) RaiseEvent EvAfficherFSIEnCours(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherAvancement(lAvancement&, sMsg$) Dim e As New clsAvancementEventArgs(lAvancement, sMsg) RaiseEvent EvAfficherAvancement(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub Tick() Dim e As New clsTickEventArgs() RaiseEvent EvTick(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub Public Sub Sablier(Optional bDesactiver As Boolean = False) Dim e As New clsSablierEventArgs(bDesactiver) RaiseEvent EvSablier(Me, e) If bDoEvents Then TraiterMsgSysteme_DoEvents() End Sub End Class clsHashQueue.vb Option Infer On ''' D'après le lien suivant : ''' http://stackoverflow.com/questions/823860/c-listt-contains-too-slow ''' <summary> ''' This is a class that mimics a queue, except the Contains() operation is O(1) ''' rather than O(n) thanks to an internal dictionary. ''' The dictionary remembers the hashcodes of the items that have been enqueued and dequeued. ''' Hashcode collisions are stored in a queue to maintain FIFO order. ''' </summary> ''' <typeparam name="T"></typeparam> Public Class HashQueue(Of T) : Inherits Queue(Of T) 'Public ReadOnly _hashes As Dictionary(Of Integer, Queue(Of T)) ' CA2104 Public _hashes As Dictionary(Of Integer, Queue(Of T)) Private ReadOnly _comp As IEqualityComparer(Of T) ' _hashes.Count doesn't always equal base.Count (due to collisions) Public Sub New(Optional comp As IEqualityComparer(Of T) = Nothing) MyBase.New() Me._comp = comp Me._hashes = New Dictionary(Of Integer, Queue(Of T))() End Sub Public Sub New(capacity%, Optional comp As IEqualityComparer(Of T) = Nothing) MyBase.New(capacity) Me._comp = comp Me._hashes = New Dictionary(Of Integer, Queue(Of T))(capacity) End Sub Public Sub New(collection As IEnumerable(Of T), _ Optional comp As IEqualityComparer(Of T) = Nothing) MyBase.New(collection) Me._comp = comp Me._hashes = New Dictionary(Of Integer, Queue(Of T))(MyBase.Count) For Each item In collection Me.EnqueueDictionary(item) Next End Sub Public Shadows Sub Enqueue(item As T) MyBase.Enqueue(item) ' Add to queue Me.EnqueueDictionary(item) End Sub Private Sub EnqueueDictionary(item As T) Dim hash As Integer = If(Me._comp Is Nothing, item.GetHashCode(), _ Me._comp.GetHashCode(item)) Dim temp As Queue(Of T) = Nothing If Not Me._hashes.TryGetValue(hash, temp) Then temp = New Queue(Of T)() Me._hashes.Add(hash, temp) End If temp.Enqueue(item) End Sub Public Shadows Function Dequeue() As T Dim result As T = MyBase.Dequeue() ' Remove from queue Dim hash As Integer = If(Me._comp Is Nothing, result.GetHashCode(), _ Me._comp.GetHashCode(result)) Dim temp As Queue(Of T) = Nothing If Me._hashes.TryGetValue(hash, temp) Then temp.Dequeue() If temp.Count = 0 Then Me._hashes.Remove(hash) End If End If Return result End Function Public Shadows Function Contains(item As T) As Boolean ' This is O(1), whereas Queue.Contains is (n) Dim hash As Integer = If(Me._comp Is Nothing, item.GetHashCode(), _ Me._comp.GetHashCode(item)) Return Me._hashes.ContainsKey(hash) End Function Public Shadows Sub Clear() For Each item In Me._hashes.Values item.Clear() Next ' Clear collision lists Me._hashes.Clear() ' Clear dictionary MyBase.Clear() ' Clear queue End Sub End Class modSendKeys.vb Imports System.Runtime.InteropServices ' DllImport Friend NotInheritable Class NativeMethods Private Sub New() End Sub '<DllImport("user32.dll", SetLastError:=True)> _ 'Public Shared Function ShowWindowAsync(hWnd As IntPtr, _ ' <MarshalAs(UnmanagedType.I4)> nCmdShow As ShowWindowCommands) _ ' As <MarshalAs(UnmanagedType.Bool)> Boolean 'End Function '<DllImport("user32.dll")> _ 'Public Shared Function ShowWindow%(ByVal hwnd%, ByVal nCmdShow%) 'End Function <DllImport("user32.dll")> _ Public Shared Function ShowWindow%(hwnd As IntPtr, nCmdShow As Int32) End Function End Class Module modSendKeys 'Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" _ ' (hWnd As IntPtr, nCmdShow As Int32) As Boolean Public Sub OuvrirBlocNotes(sChemin$, Optional sTxtRech$ = "", Optional bSensibleCasse As Boolean = False, Optional bUnicode As Boolean = False, Optional sRaccourciBlocNotesRechercherCtrl_f$ = "^(f)", Optional sRaccourciBlocNotesSensibleCasseAlt_c$ = "%(c)", Optional sRaccourciBlocNotesOccurrSuivAlt_S$ = "%(S)", Optional sExeBlocNotes$ = "Notepad.exe", Optional b1ereOuverture As Boolean = False, Optional iDelaiMSec1Ouverture% = 0, Optional bOuvrirSeulement As Boolean = False) Dim fi As New IO.FileInfo(sChemin) Dim iNbMo% = CInt(fi.Length \ (1024 * 1024)) If iNbMo > 10 Then Dim sInfo$ = "Le fichier " & sChemin & vbLf & "a une taille de " & sFormaterTailleOctets(fi.Length) & " :" & vbLf & "Etes-vous sûr de vouloir l'ouvrir avec le bloc-notes ?" If MsgBoxResult.Cancel = MsgBox(sInfo, MsgBoxStyle.OkCancel Or MsgBoxStyle.Exclamation, sTitreMsg) Then Exit Sub End If If bOuvrirSeulement Then OuvrirAppliAssociee(sChemin) Exit Sub End If Try Dim startInfo As New ProcessStartInfo Dim sSysDir$ = Environment.GetFolderPath(Environment.SpecialFolder.System) 'Dim sWinDir$ = IO.Path.GetDirectoryName(sSysDir) ' 24/09/2016 Ce dossier fonctionne dans tous les cas, y compris Windows server 2012 startInfo.FileName = sSysDir & "\" & sExeBlocNotes 'startInfo.FileName = sWinDir & "\" & sExeBlocNotes ' Ne fonctionne pas avec Windows server 2012 If Not bFichierExiste(startInfo.FileName, bPrompt:=True) Then Exit Sub ' 18/08/2016 startInfo.Arguments = sChemin Dim procNotePad As New Process With {.StartInfo = startInfo} procNotePad.Start() If sTxtRech.Length = 0 Then Exit Sub ' Need to wait for notepad to start procNotePad.WaitForInputIdle() Dim p As IntPtr = procNotePad.MainWindowHandle 'Const SW_HIDE As Int32 = 0 Const SW_SHOWNORMAL As Int32 = 1 'Const SW_SHOWMINIMIZED As Int32 = 2 'apiShowWindow(p, SW_SHOWNORMAL) Dim iRes% = NativeMethods.ShowWindow(p, SW_SHOWNORMAL) If iRes = 0 Then Exit Sub ' Pas de SendKeys si le ShowWindow a échoué ' 16/10/2016 Voir s'il faut attendre à nouveau ici, notamment lors de la 1ère ouverture If Not b1ereOuverture Then Attendre(iDelaiMSec1Ouverture) procNotePad.WaitForInputIdle() ' Alt : %, Shift : +, Ctrl : ^ 'SendKeys.SendWait("abcdef") 'SendKeys.SendWait("^({HOME})^(f)d") ' Note : en anglais les raccourcis f, c et S seront différents ' Pour traiter ce cas, il faut lire la culture en cours ' et appliquer les raccourcis du bloc-notes dans la langue en cours ' (ou sinon changer la configuration) : ' ^(f) : Ctrl+f : Menu Edition : Rechercher... ' %(c) : Alt +c : Case à cocher : sensible à la casse ' %(S) : Alt +S : Bouton Occurrence Suivante SendKeys.SendWait(sRaccourciBlocNotesRechercherCtrl_f) If bUnicode Then SendKeys.SendWait(sInsererEspacesTxt(sTxtRech)) Else SendKeys.SendWait(sTxtRech) End If If bSensibleCasse Then ' Cocher sensible à la casse dans le bloc-notes SendKeys.SendWait(sRaccourciBlocNotesSensibleCasseAlt_c) End If SendKeys.SendWait(sRaccourciBlocNotesOccurrSuivAlt_S) ' Occurrence Suivante Catch ex As Exception AfficherMsgErreur2(ex, "OuvrirBlocNotes") 'MsgBox(ex, MsgBoxStyle.Critical) End Try End Sub Private Function sInsererEspacesTxt$(sTxt$) Dim sb As New System.Text.StringBuilder For Each c As Char In sTxt sb.Append(c & " ") Next sInsererEspacesTxt = sb.ToString End Function End Module modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 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" Public Const iIndiceNulString% = -1 #Region "Gestion des fichiers" 'Public Function bChoisirFichier(ByRef sCheminFichier$, sFiltre$, sExtDef$, _ ' sTitre$, Optional sInitDir$ = "", _ ' Optional bDoitExister As Boolean = True, _ ' Optional bMultiselect As Boolean = False) As Boolean ' ' Afficher une boite de dialogue pour choisir un fichier ' ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*" ' ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier ' Static bInit As Boolean = False ' Dim ofd As New OpenFileDialog ' With ofd ' If Not bInit Then ' bInit = True ' If sInitDir.Length = 0 Then ' If sCheminFichier.Length = 0 Then ' .InitialDirectory = Application.StartupPath ' Else ' .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) ' End If ' Else ' .InitialDirectory = sInitDir ' End If ' End If ' If Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier ' .CheckFileExists = bDoitExister ' 14/10/2007 ' .DefaultExt = sExtDef ' .Filter = sFiltre ' .Multiselect = bMultiselect ' .Title = sTitre ' .ShowDialog() ' If .FileName <> "" Then sCheminFichier = .FileName : Return True ' Return False ' End With 'End Function Public Function bFichierExiste(sCheminFichier$, Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt Dim bFichierExiste0 As Boolean = IO.File.Exists(sCheminFichier) If Not bFichierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, MsgBoxStyle.Critical, m_sTitreMsg & " - Fichier introuvable") Return bFichierExiste0 End Function Public Function bFichierExisteFiltre(sCheminFiltre$, sFiltre$, Optional bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim bFichierExisteFiltre0 As Boolean Dim di As New IO.DirectoryInfo(sCheminFiltre) If Not di.Exists Then bFichierExisteFiltre0 = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre0 = (iNbFichiers > 0) Fin: If Not bFichierExisteFiltre0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, MsgBoxStyle.Critical, m_sTitreMsg & " - Fichiers introuvables") Return bFichierExisteFiltre0 End Function Public Function bFichierExisteFiltre2(sCheminFiltre$, Optional bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If String.IsNullOrEmpty(sCheminFiltre) Then Return False 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) Return bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(sCheminDossier$, sFiltre$) ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt Dim di As New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then Return 0 Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo Return fi.GetLength(0) End Function Public Function bTrouverFichier(sChemin$, sFiltre$, ByRef sCheminFichierTrouve$, Optional bPromptErr As Boolean = True) As Boolean ' Renvoyer le premier fichier correspondant au filtre sCheminFichierTrouve = "" If Not bDossierExiste(sChemin, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sChemin) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) sCheminFichierTrouve = sChemin & "\" & fi.Name Return True Next Return False End Function Public Function bCopierFichier(sCheminSrc$, sCheminDest$, Optional bPromptErr As Boolean = True, Optional bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Return False Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) Dim lTailleSrc& = New IO.FileInfo(sCheminSrc).Length If bFichierExiste(sCheminDest) Then Dim dDateDest As Date = IO.File.GetLastWriteTime(sCheminDest) Dim lTailleDest& = New IO.FileInfo(sCheminDest).Length ' Si la date et la taille sont les mêmes, la copie est déjà faite ' (la vérification du hashcode serait plus sûr mais trop longue ' de toute façon : il serait alors plus rapide de tjrs recopier) If dDateSrc = dDateDest AndAlso lTailleSrc = lTailleDest Then Return True ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Return False End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Return False 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Return False 'End If Try ' Cette fonction vient du kernel32.dll : rien à optimiser IO.File.Copy(sCheminSrc, sCheminDest) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bCopierFichier", "Impossible de copier le fichier source :" & vbLf & sCheminSrc & vbLf & "vers le fichier de destination :" & vbLf & sCheminDest, sCauseErrPoss) Return False End Try End Function Public Function bCopierFichiers(sCheminSrc$, sFiltre$, sCheminDest$, Optional bPromptErr As Boolean = True) As Boolean ' Copier tous les fichiers correspondants au filtre dans le répertoire de destination If Not bDossierExiste(sCheminSrc, bPromptErr) Then Return False If Not bDossierExiste(sCheminDest, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sCheminSrc) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) Dim sFichier$ = fi.Name Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier If Not bCopierFichier(sSrc, sDest, bPromptErr) Then Return False Next Return True End Function Public Function bSupprimerFichier(sCheminFichier$, Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then Return True If Not bFichierAccessible(sCheminFichier, bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then Return False ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "Impossible de supprimer le fichier :" & vbLf & sCheminFichier, sCauseErrPoss) 'If bPromptErr Then _ ' MsgBox("Impossible de supprimer le fichier :" & vbLf & _ ' sCheminFichier & vbLf & _ ' sCauseErrPoss, MsgBoxStyle.Critical, m_sTitreMsg) Return False End Try End Function Public Function bSupprimerFichiersFiltres(sCheminDossier$, sFiltre$, Optional bPromptErr As Boolean = False) As Boolean ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt ' Si le dossier n'existe pas, on considère que c'est un succès If Not bDossierExiste(sCheminDossier) Then Return True Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Return False Next sFichier Return True End Function Public Function bRenommerFichier(sSrc$, sDest$, Optional bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Return False If bConserverDest Then ' Cette option permet de conserver le fichier de destination s'il existe If bFichierExiste(sDest) Then ' Dans ce cas on supprime la source If Not bSupprimerFichier(sSrc, bPromptErr:=True) Then Return False Return True End If Else If Not bSupprimerFichier(sDest, bPromptErr:=True) Then Return False End If Try IO.File.Move(sSrc, sDest) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerFichier", "Impossible de renommer le fichier source :" & vbLf & sSrc & vbLf & "vers le fichier de destination :" & vbLf & sDest, sCauseErrPoss) Return False End Try End Function Public Function bDeplacerFichiers2(sSrc$, sDest$) As Boolean ' Renommer ou déplacer une arborescence de fichiers ' Attention : cette fonction nécessite la suppression du dossier src ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3 ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\ ' Cette fonction est déjà dans : modUtilFichierLT.vb Dim bStatut As Boolean, sListeErr$ = "" If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Return False Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Return False Return True End Function Public Function bDeplacerFichiers3(sCheminSrc$, sFiltre$, sCheminDest$, Optional bConserverDest As Boolean = True, Optional sExtDest$ = "", Optional sPrefixe$ = "") As Boolean ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination ' en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination ' (option par défaut pour conserver la date) If Not bVerifierCreerDossier(sCheminDest) Then Return False Dim bChExt As Boolean = False If Not String.IsNullOrEmpty(sExtDest) Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim aFi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = aFi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(aFi(i).Name) Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier ' Option possible : changer l'extension du fichier ' par exemple rename *.csv *.txt If bChExt Then sDest = sCheminDest & "\" & sPrefixe & IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Return False Next i Return True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible(sCheminFichier$, Optional bPrompt As Boolean = False, Optional bPromptFermer As Boolean = False, Optional bInexistOk As Boolean = False, Optional bPromptRetenter As Boolean = False, Optional bLectureSeule As Boolean = False, Optional bEcriture As Boolean = True) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) ' bEcriture = True par défaut (pour la rétrocompatibilité de la fct bFichierAccessible) ' Nouveau : Simple lecture : Mettre bEcriture = False ' On conserve l'option bLectureSeule pour alerter qu'un fichier doit être fermé ' par l'utilisateur (par exemple un classeur Excel ouvert) Retenter: If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas ' Et ne pas alerter non plus If Not bFichierExiste(sCheminFichier) Then Return True Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Return False End If 'Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Dim fs As IO.FileStream = Nothing Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read fs = New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() fs = Nothing Return True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", "Impossible d'accéder au fichier :" & vbLf & sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( "Veuillez fermer S.V.P. le fichier :" & vbLf & sCheminFichier & sQuestion, msgbs, m_sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & sCheminFichier & vbLf & "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & "ses attributs de protection, ou alors les droits d'accès." & sQuestion, msgbs, m_sTitreMsg) End If End If Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try If reponse = MsgBoxResult.Retry Then GoTo Retenter Return False End Function ' CA2122 : désactivé à cause maintenant de CA2135 ! '<Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub ProposerOuvrirFichier(sCheminFichier$, Optional sInfo$ = "") If String.IsNullOrEmpty(sCheminFichier) Then Exit Sub If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sMsg$ = "Le fichier " & IO.Path.GetFileName(sCheminFichier) & " a été créé avec succès :" & vbLf & sCheminFichier If Not String.IsNullOrEmpty(sInfo) Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub ' CA2122 : désactivé à cause maintenant de CA2135 ! '<Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirAppliAssociee(sCheminFichier$, Optional bMax As Boolean = False, Optional bVerifierFichier As Boolean = True, Optional sArguments$ = "") If bVerifierFichier Then ' Ne pas vérifier le fichier si c'est une URL à lancer If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub End If Using p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) p.StartInfo.Arguments = sArguments ' Il faut indiquer le chemin de l'exe si on n'utilise pas le shell 'p.StartInfo.UseShellExecute = False If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Using End Sub Public Function sFormaterTailleOctets$(lTailleOctets&, Optional bDetail As Boolean = False, Optional bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll ' 1024 est la norme actuellement employée dans Windows, ' mais 1000 sera peut être un jour la norme ' http://fr.wikipedia.org/wiki/Octet Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1)) Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1)) Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1)) Dim sAffichage$ = "" Dim sUnite$ = " octets" If lTailleOctets < 2 Then sUnite = " octet" If bDetail Then sAffichage = sFormaterNumerique(lTailleOctets) & sUnite If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko" If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo" If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go" If rNbKo >= 1 OrElse rNbMo >= 1 OrElse rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, bSupprimerPt0:=True) & sUnite End If End If sFormaterTailleOctets = sAffichage End Function Public Function sFormaterTailleKOctets$(lTailleOctets&, Optional bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier en Ko bien formatée dans une chaîne de caractère ' La méthode d'arrondie est la même que celle de l'explorateur de fichiers de Windows Dim rNbKo! = CSng(Math.Ceiling(lTailleOctets / 1024)) sFormaterTailleKOctets = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" End Function Public Function sFormaterNumerique$(rVal!, Optional bSupprimerPt0 As Boolean = True, Optional iNbDecimales% = 1) ' Formater un numérique avec une précision d'une décimale ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 ' NumberGroupSeparator : Séparateur des milliers, millions... ' NumberDecimalSeparator : Séparateur décimal ' NumberGroupSizes : 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) ' NumberDecimalDigits : 1 décimale de précision Dim nfi As New Globalization.NumberFormatInfo With { .NumberGroupSeparator = " ", .NumberDecimalSeparator = ".", .NumberGroupSizes = New Integer() {3, 3, 3}, .NumberDecimalDigits = iNbDecimales } Dim sFormatage$ = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormatage = sFormatage.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormatage = sFormatage.Replace(sb.ToString, "") End If End If Return sFormatage End Function Public Function sFormaterNumerique2$(rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 'sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général ' Vérifier , et . : Dim sVal$ = rVal.ToString("n") Dim sVal2$ = sVal.Replace(",00", "").Replace(".00", "") ' n : numérique général Return sVal2 End Function Public Function sFormaterNumeriqueLong$(lVal&) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 'sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général ' Vérifier , et . : Dim sVal$ = lVal.ToString("n") Dim sVal2$ = sVal.Replace(",00", "").Replace(".00", "") ' n : numérique général Return sVal2 End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(sCheminDossier$, Optional bPrompt As Boolean = True) As Boolean ' Vérifier si le dossier existe, et le créer sinon Dim di As New IO.DirectoryInfo(sCheminDossier) If di.Exists Then Return True Try di.Create() di = New IO.DirectoryInfo(sCheminDossier) Dim bExiste As Boolean = di.Exists Return bExiste Catch ex As Exception 'If bPrompt Then _ ' MsgBox("Impossible de créer le dossier :" & vbCrLf & _ ' sCheminDossier & vbCrLf & ex.Message, _ ' MsgBoxStyle.Critical, m_sTitreMsg) If bPrompt Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier", "Impossible de créer le dossier :" & vbCrLf & sCheminDossier) Return False End Try End Function Public Function bDossierExiste(sCheminDossier$, Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() Dim bDossierExiste0 As Boolean = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, MsgBoxStyle.Critical, m_sTitreMsg & " - Dossier introuvable") Return bDossierExiste0 End Function Public Function bRenommerDossier(sCheminDossierSrc$, sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Return False Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerDossier", "Impossible de renommer le dossier source :" & vbLf & sCheminDossierSrc & vbLf & "vers le dossier de destination :" & vbLf & sCheminDossierDest, sCauseErrPossDossier) Return False End Try End Function Public Function bDeplacerDossier(sCheminDossierSrc$, sCheminDossierDest$, Optional bPromptErr As Boolean = True) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bRenommerDossier ' Roir aussi My.Computer.MoveDirectory en DotNet2 If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Return False Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bDeplacerDossier", "Impossible de déplacer le dossier source :" & vbLf & sCheminDossierSrc & vbLf & "vers le dossier de destination :" & vbLf & sCheminDossierDest, sCauseErrPossDossier) Return False End Try End Function Public Function bSupprimerDossier(sCheminDossier$, Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then Return True Try IO.Directory.Delete(sCheminDossier, recursive:=True) ' Si l'explorateur est ouvert sur le dossier, il faut attendre qq sec. ' pour que le dossier soit bien détruit Dim i% = 0 While bDossierExiste(sCheminDossier) AndAlso i < 10 'TraiterMsgSysteme_DoEvents() 'Application.DoEvents() Threading.Thread.Sleep(1000) i += 1 End While If i = 10 Then If bPromptErr Then _ MsgBox("Impossible de supprimer le dossier :" & vbLf & sCheminDossier, MsgBoxStyle.Critical, m_sTitreMsg) Return False End If Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", "Impossible de supprimer le dossier :" & vbLf & sCheminDossier, sCauseErrPossDossier) Return False End Try End Function Public Function sDossierParent$(sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp ' (à renommer plutot en sCheminDossierParent ?) ' Ex. avec un chemin de fichier ' C:\Tmp\MonFichier.txt -> C:\Tmp ' Ex. avec un chemin de fichier avec filtre ' C:\Tmp\*.txt -> C:\Tmp sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Function sNomDossierFinal$(sCheminDossier$) ' Renvoyer le nom du dernier dossier à partir du chemin du dossier ' Exemples : ' C:\Tmp\Tmp\MonDossier -> MonDossier ' C:\MonDossier\ -> MonDossier ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé) sNomDossierFinal = sCheminDossier sCheminDossier = sEnleverSlashFinal(sCheminDossier) Dim iPosDossier% = sCheminDossier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1) End Function Public Function sExtraireChemin$(sCheminFichier$, Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", Optional ByRef sNomFichierSansExt$ = "") ' Retourner le chemin du fichier passé en argument ' Non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension ' Exemple : ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier) sNomFichier = IO.Path.GetFileName(sCheminFichier) sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier) sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt) End Function Public Function sNomDossierParent$(sCheminDossierOuFichier$, Optional sCheminReference$ = "") ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier ' sauf si le dossier parent n'existe pas : chemin de référence ' Exemples avec un dossier : ' C:\Tmp\Tmp\MonDossier -> \Tmp\MonDossier ' C:\MonDossier -> \MonDossier ' Exemples avec un fichier : ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt If String.IsNullOrEmpty(sCheminDossierOuFichier) Then Return "" sNomDossierParent = "" Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier) ' Si c'est le chemin de référence, on le renvoit tel quel Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier) If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function Dim iFin% = iPosDossier - 1 Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin) If iPosDossierParent < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent) End Function Public Function sCheminRelatif$(sCheminFichier$, sCheminReference$) ' Renvoyer le chemin relatif au chemin de référence ' à partir du chemin complet du fichier ' Exemples avec C:\ pour le chemin de référence ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt ' Exemple avec C:\Tmp1 pour le chemin de référence ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt If String.IsNullOrEmpty(sCheminFichier) Then Return "" If String.IsNullOrEmpty(sCheminReference) Then Return "" sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If String.IsNullOrEmpty(sChemin) Then Return "" If sChemin.EndsWith("\") Then Return sChemin.Substring(0, sChemin.Length - 1) Else Return sChemin End If End Function Public Function sEnleverSlashInitial$(sChemin$) ' Enlever le slash au début du chemin, le cas échéant If String.IsNullOrEmpty(sChemin) Then Return "" If sChemin.StartsWith("\") Then Return sChemin.Substring(1) Else Return sChemin End If End Function Public Function bCopierArbo(sSrc$, sDest$, ByRef bStatut As Boolean, ByRef sListeErr$, Optional sListeErrExcep$ = "") As Boolean ' Copier une arborescence de fichiers ' en retournant bStatut : Succès ou Echec de la fonction récursive ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est ' indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers ' de ce rapport si on sait déjà qu'on ne pourra les copier) ' Voir aussi : Zeta Folder XCOPY By Uwe Keim ' A small class to perform basic XCOPY like operations from within C# ' http://www.codeproject.com/KB/recipes/ZetaFolderXCopy.aspx If String.IsNullOrEmpty(sSrc) Then Return False If String.IsNullOrEmpty(sDest) Then Return False If sDest.Chars(sDest.Length - 1) <> IO.Path.DirectorySeparatorChar Then _ sDest &= IO.Path.DirectorySeparatorChar Try If Not IO.Directory.Exists(sDest) Then IO.Directory.CreateDirectory(sDest) Catch ex As Exception AfficherMsgErreur2(ex, "bCopierArbo", "Impossible de créer le dossier :" & vbLf & sDest, sCauseErrPossDossier) Return False End Try Dim aElements$() = IO.Directory.GetFileSystemEntries(sSrc) For Each sCheminElements As String In aElements Dim sNomElements$ = IO.Path.GetFileName(sCheminElements) If IO.Directory.Exists(sCheminElements) Then ' L'élement est un sous-dossier : le copier bCopierArbo(sCheminElements, sDest & sNomElements, bStatut, sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(sCheminElements, sDest & sNomElements, overwrite:=True) Catch ex As Exception If Not String.IsNullOrEmpty(sListeErrExcep) AndAlso sListeErrExcep.IndexOf(" " & sNomElements & " ") = iIndiceNulString Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next Return bStatut End Function Public Function sLecteurDossier$(sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function ' CA2122 : désactivé à cause maintenant de CA2135 ! '<System.Security.Permissions.SecurityPermissionAttribute( _ ' Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirDossier(sCheminDossier$) ' Ouvrir un dossier via l'explorateur de fichiers Using p As New Process ' Ne marche pas : 'Dim sArg$ = ", /e" ' Explorer le dossier 'p.StartInfo = New ProcessStartInfo(sCheminDossier, sArg) Dim startInfo As New ProcessStartInfo Dim sSysDir$ = Environment.GetFolderPath(Environment.SpecialFolder.System) Dim sWinDir$ = IO.Path.GetDirectoryName(sSysDir) startInfo.FileName = sWinDir & "\explorer.exe" startInfo.Arguments = sCheminDossier & ", /e" p.StartInfo = startInfo p.Start() End Using End Sub #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(sCheminFichier$, Optional bLectureSeule As Boolean = False, Optional bUnicodeUTF8 As Boolean = False) ' Lire et renvoyer le contenu d'un fichier Dim s$ = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return s Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, encodage) fs = Nothing Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbContenu.Append(vbCrLf) bDebut = True sbContenu.Append(sLigne) Loop While True End Using Return sbContenu.ToString Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function sbLireFichier(sCheminFichier$, Optional bLectureSeule As Boolean = False, Optional bUnicodeUTF8 As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier Dim sb As New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return sb Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If Using sr As New IO.StreamReader(fs, encodage) fs = Nothing Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sb.Append(vbCrLf) bDebut = True sb.Append(sLigne) Loop While True End Using Return sb Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function sbLireFichier(sCheminFichier$, encodage As Encoding, Optional bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier Dim sb As New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return sb Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, IO.FileAccess.Read, share) Using sr As New IO.StreamReader(fs, encodage) fs = Nothing Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sb.Append(vbCrLf) bDebut = True sb.Append(sLigne) Loop While True End Using Return sb Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function asLireFichier(sCheminFichier$, Optional bLectureSeule As Boolean = False, Optional bVerifierCrCrLf As Boolean = False, Optional bUnicodeUTF8 As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier Dim astr$() = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return astr Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If If bLectureSeule Then fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encodage) fs = Nothing ' 23/04/2013 Optimisation du mode bLectureSeule ' On doit enlever les lignes vides dues au double séparateur CrLf 'Return sr.ReadToEnd.Split(vbCrLf.ToCharArray, StringSplitOptions.RemoveEmptyEntries) ' 24/04/2013 Conserver strictement le même comportement de sr.ReadLine() ' en RAM Dim fluxChaine As New clsFluxChaine(sr.ReadToEnd) Return fluxChaine.asLignes(bVerifierCrCrLf) 'Dim lst As New Collections.Generic.List(Of String) 'While Not sr.EndOfStream ' ' A line is defined as a sequence of characters followed by ' ' a line feed ("\n"), a carriage return ("\r"), or ' ' a carriage return immediately followed by a line feed ("\r\n"). ' ' http://msdn.microsoft.com/en-us/library/system.io.streamreader.readline.aspx ' lst.Add(sr.ReadLine()) 'End While 'Return lst.ToArray End Using Else Return IO.File.ReadAllLines(sCheminFichier, encodage) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Private Function abLireFichier(sChemin$, Optional iTailleMaxOctets% = -1) As Byte() ' Lire un fichier en mode binaire, comme ReadAllBytes, ' mais seulement le début du fichier (les 1000 premiers octets) Dim abBuffer As Byte() Try ' Si on ne précise pas de taille limite, alors on lit tout If iTailleMaxOctets <= 0 Then abBuffer = IO.File.ReadAllBytes(sChemin) Return abBuffer End If ' Si on n'a besoin de lire que l'entête en mode binaire, ' alors limiter la lecture Using flux As IO.FileStream = IO.File.Open(sChemin, IO.FileMode.Open) abBuffer = New Byte(iTailleMaxOctets - 1) {} Dim iNbOctetsLus% = flux.Read(abBuffer, 0, iTailleMaxOctets) If iNbOctetsLus <= 0 Then Return abBuffer Dim bufferDest As Byte() bufferDest = New Byte(iNbOctetsLus - 1) {} Array.Copy(abBuffer, bufferDest, iNbOctetsLus) Return bufferDest End Using Return abBuffer Catch ex As Exception AfficherMsgErreur2(ex, "abLireFichier") Return Nothing End Try End Function Public Function bListToHashSet(lst As List(Of String), ByRef hs As HashSet(Of String), Optional bPromptErr As Boolean = True) As Boolean ' Convertir une liste en HashSet en gérant les doublons ' Si on n'affiche pas les doublons, alors on dédoublonne automatiquement 'Try : Try Catch inutile, car le constructeur ne génère pas d'exception ' ' S'il n'y a pas de doublon, alors le constructeur idoine suffit ' hs = New HashSet(Of String)(lst) 'Catch ' S'il y a une exception, alors dédoublonner la liste 'End Try hs = New HashSet(Of String) For Each sLigne As String In lst If String.IsNullOrEmpty(sLigne) Then Continue For ' 09/06/2019 If hs.Contains(sLigne) Then ' Pour la chaîne vide, dédoublonner sans signalement If bPromptErr AndAlso Not String.IsNullOrEmpty(sLigne) Then MsgBox( "bListToHashSet : la liste contient au moins un doublon : " & sLigne, MsgBoxStyle.Critical, m_sTitreMsg) : Return False Continue For End If ' 28/04/2019 Suppression des commentaires de fin de ligne, le cas échéant Dim iPosCom% = sLigne.IndexOf("//") If iPosCom > iIndiceNulString Then Dim sLigneBrute$ = sLigne.Substring(0, iPosCom).Trim If sLigneBrute.Length = 0 Then Continue For sLigne = sLigneBrute End If hs.Add(sLigne) Next Return True End Function Public Function bEcrireFichier(sCheminFichier$, sbContenu As StringBuilder, Optional bEncodageDefaut As Boolean = False, Optional bEncodageISO_8859_1 As Boolean = False, Optional bEncodageUTF8 As Boolean = False, Optional bEncodageUTF16 As Boolean = False, Optional iEncodage% = 0, Optional sEncodage$ = "", Optional bPrompt As Boolean = True, Optional ByRef sMsgErr$ = "") As Boolean ' 18/12/2017 bPromptErr:=True -> bPromptErr:=bPrompt If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPrompt) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then _ Throw New ArgumentNullException("sCheminFichier") If sbContenu Is Nothing Then Throw New ArgumentNullException("sbContenu") If String.IsNullOrEmpty(sEncodage) Then sEncodage = "" 'Dim sw As IO.StreamWriter = Nothing Try ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUTF8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf bEncodageUTF16 Then ' 28/01/2013 encodage = Encoding.Unicode ' = UTF16 ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, encoding:=encodage) sw.Write(sbContenu.ToString()) End Using 'sw.Close() Return True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(sCheminFichier$, sContenu$, Optional bEncodageDefaut As Boolean = False, Optional bEncodageISO_8859_1 As Boolean = False, Optional bEncodageUFT8 As Boolean = False, Optional iEncodage% = 0, Optional sEncodage$ = "", Optional bPromptErr As Boolean = True, Optional ByRef sMsgErr$ = "") As Boolean If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPromptErr) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then _ Throw New ArgumentNullException("sCheminFichier") If String.IsNullOrEmpty(sContenu) Then Throw New ArgumentNullException("sContenu") If String.IsNullOrEmpty(sEncodage) Then sEncodage = "" 'Dim sw As IO.StreamWriter = Nothing Try ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, encoding:=encodage) sw.Write(sContenu) End Using 'sw.Close() Return True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, sContenu$, Optional bPrompt As Boolean = True, Optional ByRef sMsgErr$ = "") As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, bInexistOk:=True, bPromptRetenter:=True) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then Throw New ArgumentNullException("sCheminFichier") If String.IsNullOrEmpty(sContenu) Then Throw New ArgumentNullException("sContenu") 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) End Using 'sw.Close() Return True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bAjouterFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, sbContenu As StringBuilder) As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, bInexistOk:=True, bPromptRetenter:=True) Then Return False If String.IsNullOrEmpty(sCheminFichier) Then Throw New ArgumentNullException("sCheminFichier") If sbContenu Is Nothing Then Throw New ArgumentNullException("sbContenu") 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) End Using 'sw.Close() Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterFichier", "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(sCheminFichier$) As Boolean ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return False Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Return False Return bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" Public Function asArgLigneCmd(sLigneCmd$, Optional bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets ' Réutilisation de cette fonction pour parser les "" : ' -------------------------------------------------- ' Cette fonction ne respecte pas le nombre de colonne, elle parse seulement les "" correctement ' (on pourrait cependant faire une option pour conserver les colonnes vides) ' Cette fonction ne sait pas non plus parser correctement une seconde ouverture de "" entre ; ' tel que : xxx;"x""x";xxx ou "xxx";"x""x";"xxx" ' En dehors des guillemets, le séparateur est l'espace et non le ; ' -------------------------------------------------- Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If ' Parser les noms cours : facile 'asArgs = Split(Command, " ") Dim lstArgs As New List(Of String) ' 16/10/2016 Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim sFichier$, sSepar$ Dim sCmd$, iLongCmd%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean Dim iCarSuiv% = 1 sCmd = sLigneCmd iLongCmd = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Chaîne vide : "" Dim s2Car$ = Mid(sCmd, iDeb, 2) If s2Car = sGm & sGm Then bNomLong = True : sSepar = sGm iFin = iDeb + 1 GoTo Suite End If ' Si le premier caractère est un guillement, c'est un nom long Dim sCar$ = Mid(sCmd, iDeb, 1) 'Dim iCar% = Asc(sCar) ' Pour debug If sCar = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong AndAlso iDeb2 < iLongCmd Then iDeb2 += 1 ' Gestion chaîne vide iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' 16/10/2016 On tolère que un " peut remplacer un espace iCarSuiv = 1 Dim iFinGM% = InStr(iDeb2 + 1, sCmd, sGm) If iFinGM > 0 AndAlso iFin > 0 AndAlso iFinGM < iFin Then iFin = iFinGM : bNomLong = True : sSepar = sGm : iCarSuiv = 0 End If ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLongCmd + 1 sFichier = Mid(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim(sFichier) If sFichier.Length > 0 Then lstArgs.Add(sFichier) If bFin OrElse iFin = iLongCmd Then Exit Do Suite: iDeb = iFin + iCarSuiv ' 1 ' 16/10/2016 On tolère que un " peut remplacer un espace, plus besoin 'If bNomLong Then iDeb = iFin + 2 If iDeb > iLongCmd Then Exit Do ' 09/10/2014 Gestion chaîne vide Loop asArgs = lstArgs.ToArray() Const iCodeGuillemets% = 34 For iNumArg As Integer = 0 To UBound(asArgs) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide Dim iLong0% = Len(sArg) If iLong0 = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(sChaine$, Optional bLimit8Car As Boolean = False, Optional bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 correct si demandé Dim iSel%, sBuffer$, sCar$, iCode%, sCarConv2$, sCarDest$ Dim bOk As Boolean, bMaj As Boolean sBuffer = Trim$(sChaine) If bLimit8Car Then sBuffer = Left$(sBuffer, 8) Const sCarConv$ = " .«»/[]:;|=,*-" ' Caractères à convertir en souligné sCarConv2 = sCarConv If Not bConserverSignePlus Then sCarConv2 &= "+" For iSel = 1 To Len(sBuffer) sCar = Mid$(sBuffer, iSel, 1) iCode = Asc(sCar) bMaj = False If iCode >= 65 AndAlso iCode <= 90 Then bMaj = True If iCode >= 192 AndAlso iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("òóôõö", sCar) > 0 Then ' 08/05/2013 If bMaj Then sCarDest = "O" Else sCarDest = "o" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ç", sCar) > 0 Then ' 12/06/2015 If bMaj Then sCarDest = "C" Else sCarDest = "c" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If bConserverSignePlus AndAlso iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 AndAlso iCode <= 90) Then bOk = True If (iCode >= 97 AndAlso iCode <= 122) Then bOk = True If (iCode >= 48 AndAlso iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function Public Function sbEnleverAccents(sbChaine As StringBuilder, Optional bMinuscule As Boolean = True) As StringBuilder ' Enlever les accents ' 18/05/2018 If sbChaine.Length = 0 Then Return New StringBuilder Dim sTexte$ = sbChaine.ToString If bMinuscule Then sTexte = sTexte.ToLower Return sbRemoveDiacritics(sTexte) End Function Public Function sEnleverAccents$(sChaine$, Optional bMinuscule As Boolean = True) ' Enlever les accents If sChaine.Length = 0 Then Return "" ' 19/05/2018 Dim sTexteSansAccents$ = sRemoveDiacritics(sChaine) If bMinuscule Then Return sTexteSansAccents.ToLower Return sTexteSansAccents End Function Private Function sRemoveDiacritics$(sTexte$) Dim sb As StringBuilder = sbRemoveDiacritics(sTexte) Dim sTexteDest$ = sb.ToString Return sTexteDest End Function Private Function sbRemoveDiacritics(sTexte$) As StringBuilder ' How do I remove diacritics (accents) from a string in .NET? ' https://stackoverflow.com/questions/249087/how-do-i-remove-diacritics-accents-from-a-string-in-net 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormC) ' Conserve les accents Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormD) ' Ok 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormKC) ' Pareil que D 'Dim sNormalizedString$ = sTexte.Normalize(NormalizationForm.FormKD) ' Pareil que D Dim sb As New StringBuilder Const cChar_ae As Char = "æ"c Const cChar_oe As Char = "œ"c Const cChar_o As Char = "o"c Const cChar_e As Char = "e"c Const cChar_a As Char = "a"c Const cCharAE As Char = "Æ"c Const cCharOE As Char = "Œ"c Const cCharO As Char = "O"c Const cCharE As Char = "E"c Const cCharA As Char = "A"c Const cChar3P As Char = "…"c ' 15/09/2018 For Each c As Char In sNormalizedString Dim unicodeCategory As Globalization.UnicodeCategory = Globalization.CharUnicodeInfo.GetUnicodeCategory(c) If (unicodeCategory <> Globalization.UnicodeCategory.NonSpacingMark) Then 'sb.Append(c) ' Remplacement des caractères collées œ -> oe ' https://www.developpez.net/forums/d1160595/dotnet/langages/csharp/suppression-caracteres-speciaux-comparaison-chaines/ ' Non, conserver tous les caractères 'If "&$*@^#-+_".IndexOf(c) <> iIndiceNulString Then Continue For If c = cCharAE Then sb.Append(cCharA) sb.Append(cCharE) ElseIf c = cCharOE Then sb.Append(cCharO) sb.Append(cCharE) ElseIf c = cChar_ae Then sb.Append(cChar_a) sb.Append(cChar_e) ElseIf c = cChar_oe Then sb.Append(cChar_o) sb.Append(cChar_e) ElseIf c = cChar3P Then ' 15/09/2018 sb.Append("...") Else sb.Append(c) End If End If Next 'Dim sTexteSansAccent$ = sb.ToString ' Non, pas besoin de renormaliser 'Dim sTexteNormalise$ = sTexteSansAccent 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormC) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormD) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormKC) 'Dim sTexteNormalise$ = sTexteSansAccent.Normalize(NormalizationForm.FormKD) Return sb End Function Public Function LireEncodage(sChemin$, ByRef sEncodage$, Optional bEncodageParDefaut As Boolean = False, Optional bEncodageParDefautUTF8 As Boolean = False) As Encoding ' Déterminer l'encodage du fichier en analysant ses 1ers octets ' (Byte Order Mark, ou BOM). Par défaut l'encodage sera ASCII si on ne trouve pas ' Indicateur d'ordre des octets ' https://fr.wikipedia.org/wiki/Indicateur_d'ordre_des_octets ' UTF-16 Big Endian : FE FF ' UTF-16 Little Endian : FF FE ' UTF-8 : EF BB BF ' SCSU : 0E FE FF ' BOCU-1 : FB EE 28 ' UTF-1 : F7 64 4C ' UTF-32 Big Endian : 00 00 FE FF ' UTF-32 Little Endian : FF FE 00 00 ' UTF-EBCDIC : DD 73 66 73 ' UTF-7 : 2B 2F 76 et l'un des octets suivants : ' [ 38 | 39 | 2B | 2F ] sEncodage = "Echec de la détection" ' Lecture de la BOM Dim bom As Byte() = New Byte(3) {} Using file As IO.FileStream = New IO.FileStream(sChemin, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) ' 05/01/2018 Need only read-only access, not write access file.Read(bom, 0, 4) End Using ' Analyse de la BOM ' UTF-16 Big Endian : FE FF If bom(0) = &HFE AndAlso bom(1) = &HFF Then sEncodage = "UTF-16 BigEndianUnicode avec BOM" Return Encoding.BigEndianUnicode End If ' UTF-16 Little Endian : FF FE If bom(0) = &HFF AndAlso bom(1) = &HFE Then sEncodage = "UTF-16 Unicode (LE : Little Endian) avec BOM" Return Encoding.Unicode End If ' UTF-8 : EF BB BF If bom(0) = &HEF AndAlso bom(1) = &HBB AndAlso bom(2) = &HBF Then sEncodage = "UTF8 avec BOM" Return Encoding.UTF8 End If ' SCSU : 0E FE FF If bom(0) = &HE AndAlso bom(1) = &HFE AndAlso bom(2) = &HFF Then sEncodage = "SCSU avec BOM" 'Return Encoding.SCSU End If ' BOCU-1 : FB EE 28 If bom(0) = &HFB AndAlso bom(1) = &HEE AndAlso bom(2) = &H28 Then sEncodage = "BOCU-1 avec BOM" 'Return Encoding.BOCU-1 End If ' UTF-1 : F7 64 4C If bom(0) = &HF7 AndAlso bom(1) = &H64 AndAlso bom(2) = &H4C Then sEncodage = "UTF-1 avec BOM" 'Return Encoding.UTF-1 End If ' UTF-32 Big Endian : 00 00 FE FF If bom(0) = &H0 AndAlso bom(1) = &H0 AndAlso bom(2) = &HFE AndAlso bom(3) = &HFF Then sEncodage = "UTF32 BE (Big Endian) avec BOM" 'Return Encoding.BigEndianUnicode : UTF16<>UTF32 End If ' UTF-32 Little Endian : FF FE 00 00 If bom(0) = &HFF AndAlso bom(1) = &HFE AndAlso bom(2) = &H0 AndAlso bom(3) = &H0 Then sEncodage = "UTF32 LE (Little Endian) avec BOM" Return Encoding.UTF32 End If ' UTF-EBCDIC : DD 73 66 73 If bom(0) = &HDD AndAlso bom(1) = &H73 AndAlso bom(2) = &H66 AndAlso bom(3) = &H73 Then sEncodage = "UTF-EBCDIC avec BOM" 'Return Encoding.UTF-EBCDIC End If ' UTF-7 : 2B 2F 76 et l'un des octets suivants : ' [ 38 | 39 | 2B | 2F ] If bom(0) = &H2B AndAlso bom(1) = &H2F AndAlso bom(2) = &H76 AndAlso (bom(3) = &H38 OrElse bom(3) = &H39 OrElse bom(3) = &H2B OrElse bom(3) = &H2F) Then sEncodage = "UTF7 avec BOM" Return Encoding.UTF7 End If If bEncodageParDefaut Then sEncodage &= ", encodage par défaut" : Return Encoding.Default If bEncodageParDefautUTF8 Then sEncodage &= ", encodage UTF8 par défaut" : Return Encoding.UTF8 sEncodage &= ", encodage ASCII par défaut" Return Encoding.ASCII End Function Public Function LireEncodageTED(sChemin$, ByRef sEncodage$, Optional bEncodageParDefaut As Boolean = False, Optional bEncodageParDefautUTF8 As Boolean = False) As Encoding ' Version avec text-encoding-detect : ' https://github.com/AutoItConsulting/text-encoding-detect sEncodage = "Echec de la détection" Dim buffer As Byte() Try ' Non, éviter quand même de tout lire, il peut y avoir de gros fichier 'buffer = IO.File.ReadAllBytes(sChemin) buffer = abLireFichier(sChemin, iTailleMaxOctets:=1000) Dim textDetect As New TextEncodingDetect() Dim encodingAutoIt As TextEncodingDetect.Encoding = textDetect.DetectEncoding(buffer, buffer.Length) Select Case encodingAutoIt Case TextEncodingDetect.Encoding.None : sEncodage = "Binaire" Case TextEncodingDetect.Encoding.Ansi : sEncodage = "Ansi" Case TextEncodingDetect.Encoding.Ascii sEncodage = "ASCII" Return Encoding.ASCII Case TextEncodingDetect.Encoding.Utf8Bom sEncodage = "UTF8 avec BOM" Return Encoding.UTF8 Case TextEncodingDetect.Encoding.Utf8Nobom sEncodage = "UTF8 sans BOM" Return Encoding.UTF8 Case TextEncodingDetect.Encoding.Utf16BeBom sEncodage = "UTF16 Big Endian avec BOM" Return Encoding.BigEndianUnicode Case TextEncodingDetect.Encoding.Utf16BeNoBom sEncodage = "UTF16 Big Endian sans BOM" Return Encoding.BigEndianUnicode Case TextEncodingDetect.Encoding.Utf16LeBom sEncodage = "UTF16 Little Endian (Unicode) avec BOM" Return Encoding.Unicode Case TextEncodingDetect.Encoding.Utf16LeNoBom sEncodage = "UTF16 Little Endian (Unicode) sans BOM" Return Encoding.Unicode End Select Catch ex As Exception sEncodage = "Echec de la détection : " & ex.Message End Try If bEncodageParDefaut Then Return Encoding.Default If bEncodageParDefautUTF8 Then Return Encoding.UTF8 Return Encoding.ASCII End Function #End Region #Region "Classe Flux Chaine" ' Equivalent de mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' mais pour une chaine : optimisation des flux Private Class clsFluxChaine Private m_iNumLigne% = 0 ' Debug Private m_sChaine$ Private m_iPos% = 0 Private Const c13 As Char = ChrW(13) ' vbCr Private Const c10 As Char = ChrW(10) ' vbLf Public Sub New(sChaine$) m_sChaine = sChaine End Sub Public Function asLignes(Optional bVerifierCrCrLf As Boolean = False) As String() Dim lst As New Collections.Generic.List(Of String) Dim iNumLigne2% = 0 Do Dim sLigne$ = StringReadLine(bVerifierCrCrLf) ' 05/02/2014 Ne pas ignorer les lignes vides, et poursuivre 'If String.IsNullOrEmpty(sLigne) Then Exit Do If IsNothing(sLigne) Then sLigne = "" lst.Add(sLigne) iNumLigne2 += 1 Loop While m_iPos < m_sChaine.Length ' 05/02/2014 'Loop While True Return lst.ToArray End Function Public Function StringReadLine$(Optional bVerifierCrCrLf As Boolean = False) If String.IsNullOrEmpty(m_sChaine) Then Return Nothing Dim iLong% = m_sChaine.Length Dim iNum% = m_iPos Do While iNum < iLong Dim ch As Char = m_sChaine.Chars(iNum) Select Case ch Case c13, c10 Dim str As String = m_sChaine.Substring(m_iPos, iNum - m_iPos) m_iPos = iNum + 1 If Not bVerifierCrCrLf Then ' 24/11/2013 If ch = c13 AndAlso m_iPos < iLong AndAlso m_sChaine.Chars(m_iPos) = c10 Then m_iPos += 1 Return str End If Dim chSuiv As Char '= m_sChaine.Chars(m_iPos) ' 17/09/2013 Maintenant qu'on fait +2, tester aussi ce cas If m_iPos < iLong Then chSuiv = m_sChaine.Chars(m_iPos) Dim chSuiv2 As Char If m_iPos < iLong - 1 Then chSuiv2 = m_sChaine.Chars(m_iPos + 1) ' 02/08/2013 Il peut arriver 13+13+10 !? If ch = c13 AndAlso m_iPos < iLong - 1 AndAlso chSuiv = c13 AndAlso chSuiv2 = c10 Then m_iPos += 2 ElseIf ch = c13 AndAlso m_iPos < iLong AndAlso chSuiv = c10 Then m_iPos += 1 End If 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str End Select iNum += 1 Loop If iNum > m_iPos Then Dim str2$ = m_sChaine.Substring(m_iPos, (iNum - m_iPos)) m_iPos = iNum 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str2 End If Return Nothing End Function End Class #End Region End Module modUtilReg.vb ' Fichier modUtilReg.vb : Module de gestion de la base de registre ' --------------------- Imports Microsoft.Win32 Module modUtilReg ' Microsoft Win32 to Microsoft .NET Framework API Map : Registry Functions ' http://msdn.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions Public Const sDossierShell$ = "shell" Public Const sDossierCmd$ = "command" Public Function bAjouterTypeFichier(sExtension$, sTypeFichier$, _ Optional sDescriptionExtension$ = "", _ Optional bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de fichier à une application par défaut ' (via le double-clic ou bien le menu contextuel Ouvrir) ' Exemple : associer .dat à mon application.exe Try If bEnlever Then If bCleRegistreCRExiste(sExtension) Then Registry.ClassesRoot.DeleteSubKeyTree(sExtension) End If Else If Not bCleRegistreCRExiste(sExtension) Then Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension) rk.SetValue("", sTypeFichier) If sDescriptionExtension.Length > 0 Then rk.SetValue("Content Type", sDescriptionExtension) End If End Using 'rk.Close() End If End If Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterTypeFichier") Return False End Try End Function Public Function bAjouterMenuContextuel(sTypeFichier$, sCmd$, _ Optional bPrompt As Boolean = True, _ Optional bEnlever As Boolean = False, _ Optional sDescriptionCmd$ = "", _ Optional sCheminExe$ = "", _ Optional sCmdDef$ = """%1""", _ Optional sDescriptionTypeFichier$ = "", _ Optional bEnleverTypeFichier As Boolean = False) As Boolean ' Ajouter un menu contextuel dans la base de registre ' de type ClassesRoot : fichier associé à une application standard ' Exemple : ajouter le menu contextuel "Convertir en Html" sur les fichiers projet VB6 ' sTypeFichier = "VisualBasic.Project" ' sCmd = "ConvertirEnHtml" ' sDescriptionCmd = "Convertir en Html" ' sCheminExe = "C:\Program Files\VB2Html\VB2Html.exe" Try ' D'abord vérifier si la clé principale existe If Not bCleRegistreCRExiste(sTypeFichier) Then If bEnlever Then bAjouterMenuContextuel = True : Exit Function Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sTypeFichier) If sDescriptionTypeFichier.Length > 0 Then rk.SetValue("", sDescriptionTypeFichier) End If End Using End If Dim sCleDescriptionCmd$ = sTypeFichier & "\" & sDossierShell & "\" & sCmd If bEnlever Then If bEnleverTypeFichier Then ' Si c'est un type de fichier créé à l'occasion ' il faut aussi le supprimer (mais seulement dans ce cas) If bCleRegistreCRExiste(sTypeFichier) Then Registry.ClassesRoot.DeleteSubKeyTree(sTypeFichier) If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre", _ MsgBoxStyle.Information, m_sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, m_sTitreMsg) End If Else If bCleRegistreCRExiste(sCleDescriptionCmd) Then Registry.ClassesRoot.DeleteSubKeyTree(sCleDescriptionCmd) If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, m_sTitreMsg) Else If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "est introuvable dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, m_sTitreMsg) End If End If bAjouterMenuContextuel = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sDescriptionCmd) End Using 'rk.Close() Dim sCleCmd$ = sTypeFichier & "\" & sDossierShell & "\" & sCmd & "\" & sDossierCmd Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Ajouter automatiquement des guillemets " si le chemin contient au moins un espace If sCheminExe.IndexOf(" ") > -1 Then _ sCheminExe = """" & sCheminExe & """" rk.SetValue("", sCheminExe & " " & sCmdDef) End Using 'rk.Close() If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été ajouté avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", MsgBoxStyle.Information, m_sTitreMsg) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel", "Cause possible : L'application doit être lancée en tant qu'admin. pour cette opération.") Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, _ Optional sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' Note : la sous-clé est ici un "sous-dossier" (et non un "fichier") Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey( _ sCle & "\" & sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesCR$() = rkCRCle.GetSubKeyNames If IsNothing(rkCRCle) Then Return False End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, sSousCle$, _ ByRef sValSousCle$) As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' et si elle est trouvée, alors lire la valeur de la sous-clé ' Renvoyer True si la valeur de la sous-clé a pu être lue ' Note : la sous-clé est ici un "fichier" (et non un "sous-dossier") sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey(sCle) If IsNothing(rkCRCle) Then Return False ' Pour lire la valeur par défaut d'un "dossier", laisser "" Dim oVal As Object = rkCRCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreLMExiste(sCle$, _ Optional sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional sNouvValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé LocalMachine existe dans la base de registre sValSousCle = "" Try Dim bEcriture As Boolean = False If sNouvValSousCle.Length > 0 Then bEcriture = True ' Si la clé n'existe pas, on passe dans le Catch Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sCle, _ writable:=bEcriture) ' Lecture de la valeur de la sous-clé (sous forme de "fichier") Dim oVal As Object = rkLMCle.GetValue(sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesLM$() = rkLMCle.GetSubKeyNames ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function bCleRegistreCUExiste(sCle$, _ Optional sSousCle$ = "", _ Optional ByRef sValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé CurrentUser existe dans la base de registre ' et si oui renvoyer la valeur de la sous-clé sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) Dim oVal As Object = rkCUCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCUCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function asListeSousClesCU(sCle$) As String() ' Renvoyer la liste des sous-clés de type CurrentUser asListeSousClesCU = Nothing Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) If IsNothing(rkCUCle) Then Exit Function asListeSousClesCU = rkCUCle.GetSubKeyNames End Using ' rkCUCle.Close() est automatiquement appelé Catch End Try End Function End Module ucSortableListView.vb Public Class SortableListView : Inherits ListView Public Enum enumIdxImgTri iIdxImgTriDesactive = 0 iIdxImgTriDescendant = 1 iIdxImgTriMontant = 2 End Enum ' Fields Private m_components As System.ComponentModel.IContainer = Nothing Private m_iColTri As Integer = -1 ' Possibilité d'attribuer un tri d'une colonne à une autre ' (ex.: une colonne affiche la taille en Ko en mode texte, mais on tri en octets) ' (actif si l'indice de la colonne est >=0) Public m_iColTriSrc% = -1 Public m_iColTriDest% = -1 Public m_bNePasTrier As Boolean ' Ne pas trier pendant une recherche de fichiers par exemple Private m_msgDelegue As clsMsgDelegue Public m_bTriEnCours As Boolean = False ' Methods Public Sub New() Me.InitializeComponent() MyBase.View = View.Details MyBase.AllowColumnReorder = True MyBase.FullRowSelect = True MyBase.ShowItemToolTips = True End Sub Public Sub DefinirMsgDelegue(msgDelegue As clsMsgDelegue) m_msgDelegue = msgDelegue End Sub Protected Overrides Sub Dispose(disposing As Boolean) If (disposing AndAlso (Not Me.m_components Is Nothing)) Then Me.m_components.Dispose() End If MyBase.Dispose(disposing) End Sub Private Sub InitializeComponent() Me.m_components = New System.ComponentModel.Container End Sub Public Sub DesactiverTri() If Not IsNothing(MyBase.ListViewItemSorter) Then If m_bTriEnCours Then While m_bTriEnCours Attendre() TraiterMsgSysteme_DoEvents() End While End If ' Enlever la précédente couleur de tri (en conservant les autres couleurs) Dim hsCoul As New HashSet(Of Color) ' Couleurs utilisées actuellement (sauf blanc et grisé) Dim coulTri As Color = Color.WhiteSmoke 'LightGray ' SystemColors.Info : non ! Dim coulVide As Color = Color.White EnleverColoriageTri(hsCoul, coulTri, coulVide) End If MyBase.ListViewItemSorter = Nothing ' 16/12/2012 Désactiver le tri End Sub 'Protected Overrides Sub OnColumnClick(e As ColumnClickEventArgs) ' MyBase.OnColumnClick(e) 'End Sub 'Protected Overrides Sub OnColumnReordered(e As ColumnReorderedEventArgs) ' ' Drag & drop des colonnes pour changer l'ordre d'affichage des colonnes ' ' on récupère après coup l'événement ' MyBase.OnColumnReordered(e) 'End Sub Private Sub list_ColumnClick(sender As Object, e As ColumnClickEventArgs) _ Handles MyBase.ColumnClick If m_bNePasTrier Then DesactiverTri() Exit Sub ' 18/11/2012 End If m_bTriEnCours = True m_msgDelegue.AfficherMsg("Tri en cours...") m_msgDelegue.Sablier() Me.SuspendLayout() If e.Column <> m_iColTri Then m_iColTri = e.Column MyBase.Sorting = SortOrder.Ascending ElseIf MyBase.Sorting = SortOrder.Ascending Then MyBase.Sorting = SortOrder.Descending Else MyBase.Sorting = SortOrder.Ascending End If Dim iCol% = e.Column Dim iColTri0% = iCol ' Possibilité d'attribuer un tri d'une colonne à une autre ' (ex.: une colonne affiche la taille en Ko en mode texte, mais on tri en octets) ' (actif si l'indice de la colonne est >=0) If iCol = m_iColTriSrc Then iColTri0 = m_iColTriDest Dim typeDonneeColonne As Type = TryCast(MyBase.Columns.Item(iColTri0).Tag, Type) MyBase.ListViewItemSorter = New ListViewItemComparer(iColTri0, MyBase.Sorting, typeDonneeColonne) m_msgDelegue.AfficherMsg("Tri en cours 2...") ' Enlever la précédente couleur de tri (en conservant les autres couleurs) Dim hsCoul As New HashSet(Of Color) ' Couleurs utilisées actuellement (sauf blanc et grisé) Dim coulTri As Color = Color.WhiteSmoke 'LightGray ' SystemColors.Info : non ! Dim coulVide As Color = Color.White EnleverColoriageTri(hsCoul, coulTri, coulVide) ' Colorier la colonne de tri (sauf les colonnes déjà coloriées au départ) ' Il y a 3 images : 0 : pas de tri, 1 : tri descendant, 2 : tri montant ' Initialisation : Me.lvResultats.SmallImageList = Me.imgLstLVH 'If Not IsNothing(Me.SmallImageList) Then _ Me.Columns.Item(iCol).ImageIndex = CInt(IIf(MyBase.Sorting = SortOrder.Descending, _ enumIdxImgTri.iIdxImgTriDescendant, enumIdxImgTri.iIdxImgTriMontant)) m_msgDelegue.AfficherMsg("Tri en cours 3...") 'Dim iNbItems% = Me.Items.Count 'Dim iNumItem% = 0 For Each lvi As ListViewItem In Me.Items ' Comme on a mis le SuspendLayout, ça ne sert à rien d'envoyer des msg 'iNumItem += 1 'If iNumItem Mod 10000 = 0 Then ' Me.ResumeLayout() ' m_msgDelegue.AfficherMsg("Tri en cours 3 " & iNumItem & "/" & iNbItems & "...") ' TraiterMsgSysteme_DoEvents() ' If m_msgDelegue.m_bAnnuler Then Exit For ' 19/03/2017 ' Me.SuspendLayout() 'End If If iCol >= lvi.SubItems.Count Then Continue For ' Msg d'erreur : un seul item Dim coulSousItem As Color = lvi.SubItems(iCol).BackColor If Not hsCoul.Contains(coulSousItem) Then lvi.SubItems(iCol).BackColor = coulTri Next m_msgDelegue.AfficherMsg("Tri en cours 4...") Me.ResumeLayout() m_msgDelegue.AfficherMsg("Tri terminé.") m_msgDelegue.Sablier(bDesactiver:=True) m_bTriEnCours = False End Sub Private Sub EnleverColoriageTri(hsCoul As HashSet(Of Color), _ coulTri As Color, coulVide As Color) For i As Integer = 0 To Me.Columns.Count - 1 'If Not IsNothing(Me.SmallImageList) Then _ Me.Columns.Item(i).ImageIndex = enumIdxImgTri.iIdxImgTriDesactive For Each lvi As ListViewItem In Me.Items If i >= lvi.SubItems.Count Then Continue For ' Msg d'erreur : un seul item Dim coulSousItem As Color = lvi.SubItems(i).BackColor If coulSousItem.ToArgb <> coulVide.ToArgb AndAlso _ coulSousItem.ToArgb <> coulTri.ToArgb AndAlso _ Not hsCoul.Contains(coulSousItem) Then hsCoul.Add(coulSousItem) If Not hsCoul.Contains(coulSousItem) Then lvi.SubItems(i).BackColor = coulVide Next Next End Sub #Region "ListViewItemComparer" ' Nested Types Public Class ListViewItemComparer : Implements Collections.IComparer ' Fields Private col As Integer Private columnType As Type Private order As SortOrder ' Methods Public Sub New() Me.col = 0 Me.order = SortOrder.Ascending Me.columnType = Nothing End Sub Public Sub New(column As Integer, order As SortOrder, type As Type) Me.col = column Me.order = order Me.columnType = type End Sub Public Function Compare%(olviX As Object, olviY As Object) _ Implements Collections.IComparer.Compare Dim iRetour% = -1 Dim iCol% = Me.col Dim sTxtX$ = sLireColonne(olviX, iCol) Dim sTxtY$ = sLireColonne(olviY, iCol) If sTxtX.Length = 0 OrElse sTxtY.Length = 0 OrElse _ (Me.columnType Is Nothing) OrElse _ (Me.columnType Is GetType(String)) Then iRetour = String.Compare(sTxtX, sTxtY) ElseIf (Me.columnType Is GetType(DateTime)) Then iRetour = DateTime.Compare( _ DateTime.Parse(sTxtX), _ DateTime.Parse(sTxtY)) ElseIf (Me.columnType Is GetType(Integer)) Then Dim i1% = Integer.Parse(sTxtX) Dim i2% = Integer.Parse(sTxtY) iRetour = (i1 - i2) ElseIf (Me.columnType Is GetType(Long)) Then Dim i1& = Long.Parse(sTxtX) Dim i2& = Long.Parse(sTxtY) iRetour = Math.Sign(i1 - i2) ElseIf (Me.columnType Is GetType(Single)) Then Dim s1! = Single.Parse(sTxtX) Dim s2! = Single.Parse(sTxtY) If s1 = s2 Then iRetour = 0 ElseIf s1 > s2 Then iRetour = 1 Else iRetour = -1 End If ElseIf (Me.columnType Is GetType(Double)) Then Dim d1 As Double = Double.Parse(sTxtX) Dim d2 As Double = Double.Parse(sTxtY) If d1 = d2 Then iRetour = 0 ElseIf d1 > d2 Then iRetour = 1 Else iRetour = -1 End If End If If Me.order = SortOrder.Descending Then iRetour = -iRetour Return iRetour End Function Private Function sLireColonne$(olvi As Object, iCol%) sLireColonne = "" Dim lviX As ListViewItem = DirectCast(olvi, ListViewItem) If iCol >= lviX.SubItems.Count Then Exit Function Dim lvsi As ListViewItem.ListViewSubItem = lviX.SubItems.Item(iCol) If String.IsNullOrEmpty(lvsi.Text) Then Exit Function Return lvsi.Text End Function 'Private Function OKToCompare(X As Object, Y As Object) As Boolean ' If CompareOK(X) Then ' OKToCompare = Object.ReferenceEquals(X.GetType, Y.GetType) ' Else : OKToCompare = False ' End If 'End Function 'Private Function CompareOK(obj As Object) As Boolean ' CompareOK = False ' Assume not OK ' If obj Is Nothing Then Exit Function ' Dim IInfo() As Type = obj.GetType.GetInterfaces ' If IInfo Is Nothing Then Exit Function ' For Each Inter As Type In IInfo ' If Inter.Name.ToLower.StartsWith("icomparable") Then ' Return True ' End If ' Next 'End Function End Class #End Region End Class