VBWinDiff v1.1.3.*Table des procédures 1 - AssemblyInfo.vb 2 - frmVBWinDiff.vb 2.1 - Private Function bConfirmerTailleFichier 2.2 - Private Function bEcrireFichiers 2.3 - Private Function bLireCleBRWinMerge 2.4 - Private Sub ActivationCmdPage 2.5 - Private Sub AfficherMessage 2.6 - Private Sub chkAccents_Click 2.7 - Private Sub chkCasse_Click 2.8 - Private Sub chkEspaces_Click 2.9 - Private Sub chkEspacesInsec_Click 2.10 - Private Sub chkNum_Click 2.11 - Private Sub chkPaginer_CheckedChanged 2.12 - Private Sub chkParag_Click 2.13 - Private Sub chkPhrases_CheckedChanged 2.14 - Private Sub chkPhrases_Click 2.15 - Private Sub chkPonctuation_CheckedChanged 2.16 - Private Sub chkPonctuation_Click 2.17 - Private Sub chkQuotes_Click 2.18 - Private Sub chkTout_Click 2.19 - Private Sub chkWinDiff_Click 2.20 - Private Sub cmdAjouterRaccourci_Click 2.21 - Private Sub cmdComp_Click 2.22 - Private Sub cmdEnleverRaccourci_Click 2.23 - Private Sub cmdPagePreced_Click 2.24 - Private Sub cmdPageSuiv_Click 2.25 - Private Sub Comparer 2.26 - Private Sub frmVBWinDiff_Load 2.27 - Private Sub frmVBWinDiff_Shown 2.28 - Private Sub GererActivationPhrasesEtParag 2.29 - Private Sub GererChkTout 2.30 - Private Sub PresicerInfoBullesWinDiff 2.31 - Private Sub VerifierRaccourci 3 - modConst.vb 4 - modDepart.vb 4.1 - Public Sub DefinirTitreApplication 4.2 - Public Sub Depart 4.3 - Public Sub Main 5 - modUtil.vb 5.1 - Public Sub AfficherMsgErreur2 5.2 - Public Sub CopierPressePapier 5.3 - Public Sub LibererRessourceDotNet 5.4 - Public Sub Sablier 5.5 - Public Sub TraiterMsgSysteme_DoEvents 6 - modVBWinDiff.vb 6.1 - Private Sub LireInfoFichier 6.2 - Private Sub Paginer 6.3 - Public Function bAjouterInfo 6.4 - Public Function bEnleverAccents 6.5 - Public Function bEnleverMajuscules 6.6 - Public Function bEnleverPonctuation 6.7 - Public Function bPaginerFichiers 6.8 - Public Sub EnleverEspaces 6.9 - Public Sub EnleverEspInsec 6.10 - Public Sub FusionnerMotsCoupes 6.11 - Public Sub New 6.12 - Public Sub NormaliserQuotes 7 - clsDicoTri.vb 7.1 - Protected Sub New 7.2 - Public Function Trier 7.3 - Sub New 8 - modEncodage.vb 8.1 - Private Function CheckUtf16Ascii 8.2 - Private Function CheckUtf8 8.3 - Private Shared Function CheckUtf16NewlineChars 8.4 - Private Shared Function DoesContainNulls 8.5 - Public Function CheckBom 8.6 - Public Function DetectEncoding 8.7 - Public Shared Function GetBomLengthFromEncodingMode 8.8 - Public WriteOnly Property NullSuggestsBinary 8.9 - Public WriteOnly Property Utf16ExpectedNullPercent 8.10 - Public WriteOnly Property Utf16UnexpectedNullPercent 9 - modRaccourci.vb 9.1 - Sub CreerRaccourci 10 - modUtilFichier.vb 10.1 - Private Function abLireFichier 10.2 - Private Function sbRemoveDiacritics 10.3 - Private Function sRemoveDiacritics$ 10.4 - Public Function asArgLigneCmd 10.5 - Public Function asLignes 10.6 - Public Function asLireFichier 10.7 - Public Function bAjouterFichier 10.8 - Public Function bAjouterFichier 10.9 - Public Function bCopierArbo 10.10 - Public Function bCopierFichier 10.11 - Public Function bCopierFichiers 10.12 - Public Function bDeplacerDossier 10.13 - Public Function bDeplacerFichiers2 10.14 - Public Function bDeplacerFichiers3 10.15 - Public Function bDossierExiste 10.16 - Public Function bEcrireFichier 10.17 - Public Function bEcrireFichier 10.18 - Public Function bFichierAccessible 10.19 - Public Function bFichierExiste 10.20 - Public Function bFichierExisteFiltre 10.21 - Public Function bFichierExisteFiltre2 10.22 - Public Function bListToHashSet 10.23 - Public Function bReencoder 10.24 - Public Function bRenommerDossier 10.25 - Public Function bRenommerFichier 10.26 - Public Function bSupprimerDossier 10.27 - Public Function bSupprimerFichier 10.28 - Public Function bSupprimerFichiersFiltres 10.29 - Public Function bTrouverFichier 10.30 - Public Function bVerifierCreerDossier 10.31 - Public Function iNbFichiersFiltres% 10.32 - Public Function LireEncodage 10.33 - Public Function LireEncodageTED 10.34 - Public Function sbEnleverAccents 10.35 - Public Function sbLireFichier 10.36 - Public Function sbLireFichier 10.37 - Public Function sCheminRelatif$ 10.38 - Public Function sConvNomDos$ 10.39 - Public Function sDossierParent$ 10.40 - Public Function sEnleverAccents$ 10.41 - Public Function sEnleverSlashFinal$ 10.42 - Public Function sEnleverSlashInitial$ 10.43 - Public Function sExtraireChemin$ 10.44 - Public Function sFormaterNumerique$ 10.45 - Public Function sFormaterNumerique2$ 10.46 - Public Function sFormaterNumeriqueLong$ 10.47 - Public Function sFormaterTailleKOctets$ 10.48 - Public Function sFormaterTailleOctets$ 10.49 - Public Function sLecteurDossier$ 10.50 - Public Function sLireFichier$ 10.51 - Public Function sNomDossierFinal$ 10.52 - Public Function sNomDossierParent$ 10.53 - Public Function StringReadLine$ 10.54 - Public Sub New 10.55 - Public SubOuvrirAppliAssociee 10.56 - Public SubOuvrirDossier 10.57 - Public SubProposerOuvrirFichier 11 - modUtilReg.vb 11.1 - Public Function asListeSousClesCU 11.2 - Public Function bAjouterMenuContextuel 11.3 - Public Function bAjouterTypeFichier 11.4 - Public Function bCleRegistreCRExiste 11.5 - Public Function bCleRegistreCRExiste 11.6 - Public Function bCleRegistreCUExiste 11.7 - Public Function bCleRegistreLMExiste 12 - UniversalComparer.vb 12.1 - Public Function Compare 12.2 - Public Function Compare 12.3 - Public Sub New AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("VBWinDiff")> <Assembly: AssemblyDescription( _ "VBWinDiff : Interface d'options pour le comparateur Windiff et WinMerge")> <Assembly: AssemblyCompany("")> <Assembly: AssemblyProduct("VBWinDiff")> <Assembly: AssemblyCopyright("Copyright © 2024")> <Assembly: AssemblyTrademark("VBWinDiff")> <Assembly: AssemblyVersion("1.1.3.*")> frmVBWinDiff.vb ' Fichier frmVBWinDiff.vb : Interface d'options pour le comparateur WinDiff et WinMerge ' -------------------- ' 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 ' a pour Array (tableau) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ Imports System.Text ' Pour StringBuilder Public Class frmVBWinDiff #Region "Constantes" Private Const sNomExeWinDiff$ = "WinDiff.exe" Private Const sNom_Exe_WinDiff$ = "WinDiff._exe_" Private Const sExeVBWinDiff$ = "VBWinDiff.exe" Private Const sLienExeVBWinDiff$ = sExeVBWinDiff & ".lnk" #End Region #Region "Configuration" ' Taille de la page en octets Private Const iTaillePage% = 50000 ' Prod. #End Region #Region "Interface" Public m_sCheminFichier1$ = "" Public m_sCheminFichier2$ = "" #End Region #Region "Déclarations" Private m_iNbPages% = 1 Private m_iNumPage% = 1 Private m_sCheminWinMerge$ = "" #End Region #Region "Initialisations" Private Sub frmVBWinDiff_Load(sender As Object, e As EventArgs) Handles Me.Load ' modUtilFichier peut maintenant être compilé dans une dll DefinirTitreApplication(sTitreMsg) End Sub Private Sub frmVBWinDiff_Shown(sender As Object, e As EventArgs) _ Handles Me.Shown Dim sVersion$ = " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sDebug$ = " - Debug" Dim sTxt$ = Me.Text & sVersion If bDebug Then sTxt &= sDebug Me.Text = sTxt Dim bModeConfig As Boolean = False If Me.m_sCheminFichier1.Length = 0 Then bModeConfig = True Else If Not bFichierExiste(Me.m_sCheminFichier1, bPrompt:=True) Then bModeConfig = True If Not bFichierExiste(Me.m_sCheminFichier2, bPrompt:=True) Then bModeConfig = True End If If bModeConfig And bRelease Then Me.cmdAjouterRaccourci.Visible = True Me.cmdEnleverRaccourci.Visible = True Me.cmdComp.Visible = False Me.cmdAnnuler.Visible = False Me.lblChemin1.Text = "" Me.lblChemin2.Text = "" VerifierRaccourci() Exit Sub Else Me.cmdAjouterRaccourci.Visible = False Me.cmdEnleverRaccourci.Visible = False End If ' bDebug Dim sCheminFichier1$, sCheminFichier2$ sCheminFichier1 = m_sCheminFichier1 sCheminFichier2 = m_sCheminFichier2 If bDebug Then 'sCheminFichier1 = Application.StartupPath & "\Fichier1.txt" 'sCheminFichier2 = Application.StartupPath & "\Fichier2.txt" End If ' 04/01/2014 On pagine le second fichier par rapport aux tronçons du 1er, de taille fixe ' mieux vaut tjrs inverser If Not String.IsNullOrEmpty(sCheminFichier1) AndAlso Not String.IsNullOrEmpty(sCheminFichier2) AndAlso bFichierExiste(sCheminFichier1) AndAlso bFichierExiste(sCheminFichier2) Then Dim lLong1& = (New IO.FileInfo(sCheminFichier1)).Length Dim lLong2& = (New IO.FileInfo(sCheminFichier2)).Length If lLong2 < lLong1 Then Dim sCheminTmp$ = sCheminFichier1 sCheminFichier1 = sCheminFichier2 sCheminFichier2 = sCheminTmp m_sCheminFichier1 = sCheminFichier1 m_sCheminFichier2 = sCheminFichier2 End If ' 04/01/2014 ' 09/05/2014 Paginer ssi Windiff (WinMerge : pas besoin) If Me.chkWinDiff.Checked AndAlso (lLong1 > iTaillePage OrElse lLong2 > iTaillePage) Then Me.chkPaginer.Checked = True End If If bDebug Then Me.chkTout.Checked = False Me.chkAccents.Checked = False Me.chkPonctuation.Checked = False Me.chkCasse.Checked = False Me.chkEspacesInsec.Checked = False Me.chkEspaces.Checked = False Me.chkQuotes.Checked = False Me.chkInfo.Checked = True Me.chkPhrases.Checked = False Me.chkPaginer.Checked = False Me.chkRatio.Checked = False Me.chkWinDiff.Checked = False Me.chkParag.Checked = False Me.chkNum.Checked = False End If Me.lblChemin1.Text = sCheminFichier1 Me.lblChemin2.Text = sCheminFichier2 PresicerInfoBullesWinDiff() End Sub Private Sub AfficherMessage(sMsg$) Me.sbStatusBar.Text = sMsg Application.DoEvents() End Sub #End Region #Region "Conversion" Private Function bConfirmerTailleFichier(sCheminFichier$) As Boolean Dim lTaille& = (New IO.FileInfo(sCheminFichier)).Length ' Afficher un avertissement ssi la taille risque vraiment de faire planter WinDiff If lTaille <= iTaillePage * 5 Then Return True If MsgBoxResult.Cancel = MsgBox("La taille du fichier (" & sFormaterTailleOctets(lTaille) & ") dépasse la taille limite conseillée (" & sFormaterTailleOctets(CLng(iTaillePage * 1.024), bSupprimerPt0:=True) & ") pour WinDiff :" & vbLf & sCheminFichier & vbLf & "Etes-vous sûr de vouloir comparer sans pagination ?", MsgBoxStyle.OkCancel Or MsgBoxStyle.Exclamation, sTitreMsg) Then Return False Return True End Function Private Sub Comparer() Sablier() ' 04/07/2022 Me.cmdAnnuler.Enabled = True Me.cmdComp.Enabled = False Dim sCheminFichier1$ = Me.lblChemin1.Text Dim sCheminFichier2$ = Me.lblChemin2.Text Dim sCheminFichier1Orig$ = sCheminFichier1 Dim sCheminFichier2Orig$ = sCheminFichier2 Dim sChemin$ = Application.StartupPath If Not bSupprimerFichiersFiltres(sChemin, sFiltreTmp) Then GoTo Fin If Not bSupprimerFichiersFiltres(sChemin, sFiltreFusion) Then GoTo Fin If Not bFichierExiste(sCheminFichier1, bPrompt:=True) Then GoTo Fin If Not bFichierExiste(sCheminFichier2, bPrompt:=True) Then GoTo Fin Dim sCheminWinDiff$ = Application.StartupPath & "\" & sNomExeWinDiff ' Zip sur VBFrance : Si ._exe_ présent alors -> .exe 'If Not bFichierExiste(sCheminWinDiff, bPrompt:=True) Then GoTo Fin If Not bFichierExiste(sCheminWinDiff) Then Dim sCheminWinDiff2$ = Application.StartupPath & "\" & sNom_Exe_WinDiff If Not bFichierExiste(sCheminWinDiff2) Then If Not bFichierExiste(sCheminWinDiff, bPrompt:=True) Then GoTo Fin End If If Not bCopierFichier(sCheminWinDiff2, sCheminWinDiff) Then GoTo Fin bSupprimerFichier(sCheminWinDiff2) End If Const bDebugSplit As Boolean = False Dim sbSrc1, sbSrc2 As StringBuilder Dim iIdxSrcOrig1%, iIdxSrcOrig2% ' 03/09/2022 Dim sEncodage1$ = "", sEncodage2$ = "" ' Problème : parfois il faut laisser par défaut, parfois UTF8, comment choisir ? 'Dim encod1 As Encoding = LireEncodage(sCheminFichier1, sEncodage1, bEncodageParDefautUTF8:=True) 'Dim encod2 As Encoding = LireEncodage(sCheminFichier2, sEncodage2, bEncodageParDefautUTF8:=True) ' Solution : https://github.com/AutoItConsulting/text-encoding-detect Dim encod1 As Encoding = LireEncodageTED(sCheminFichier1, sEncodage1, bEncodageParDefaut:=True) Dim encod2 As Encoding = LireEncodageTED(sCheminFichier2, sEncodage2, bEncodageParDefaut:=True) ' 04/01/2014 Paginer ici une fois pour toutes If Me.chkPaginer.Checked Then Dim iNbPages% = Me.m_iNbPages Dim dico1Pages As Dictionary(Of Integer, clsPage) = Nothing Dim dico2Pages As Dictionary(Of Integer, clsPage) = Nothing If Not bPaginerFichiers(sCheminFichier1, sCheminFichier2, iTaillePage, iNbPages, dico1Pages, dico2Pages, Me.chkRatio.Checked, encod1, encod2) Then GoTo Fin Me.m_iNbPages = iNbPages sbSrc1 = dico1Pages(Me.m_iNumPage - 1).sbPage sbSrc2 = dico2Pages(Me.m_iNumPage - 1).sbPage iIdxSrcOrig1 = dico1Pages(Me.m_iNumPage - 1).iIndexSrc iIdxSrcOrig2 = dico2Pages(Me.m_iNumPage - 1).iIndexSrc Else If Me.chkWinDiff.Checked Then ' 09/05/2014 If Not bConfirmerTailleFichier(sCheminFichier1) Then GoTo Fin If Not bConfirmerTailleFichier(sCheminFichier2) Then GoTo Fin End If sbSrc1 = sbLireFichier(sCheminFichier1, encod1) sbSrc2 = sbLireFichier(sCheminFichier2, encod2) 'If bDebugSplit Then Debug.WriteLine("Lecture :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") iIdxSrcOrig1 = 0 : iIdxSrcOrig2 = 0 End If Dim iNbEcritures% = 0 If Not Me.chkEspacesInsec.Checked Then iNbEcritures += 1 If Not Me.chkEspaces.Checked Then iNbEcritures += 1 If Not Me.chkAccents.Checked Then iNbEcritures += 1 If Not Me.chkCasse.Checked Then iNbEcritures += 1 If Not Me.chkPonctuation.Checked Then iNbEcritures += 1 If Not Me.chkQuotes.Checked Then iNbEcritures += 1 Dim iNbEcrituresTot% = iNbEcritures Dim bEcriture As Boolean = False If Me.chkInfo.Checked OrElse iNbEcritures > 0 Then bEcriture = True Dim sbDest1 As StringBuilder = Nothing Dim sbDest2 As StringBuilder = Nothing Dim sbSrcOrig1 As New StringBuilder sbSrcOrig1.Append(sbSrc1) Dim sbSrcOrig2 As New StringBuilder sbSrcOrig2.Append(sbSrc2) If Not Me.chkQuotes.Checked Then NormaliserQuotes(sbSrc1, sbDest1) : sbSrc1 = sbDest1 NormaliserQuotes(sbSrc2, sbDest2) : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 'If bDebugSplit Then Debug.WriteLine("Quotes :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If Not Me.chkAccents.Checked Then ' 26/11/2021 Ne pas enlever la casse ici si on ne le demande pas Dim bMinuscule As Boolean = Not Me.chkCasse.Checked If Not bEnleverAccents(sCheminFichier1, sbSrc1, sbDest1, bMinuscule) Then GoTo Fin If Not bEnleverAccents(sCheminFichier2, sbSrc2, sbDest2, bMinuscule) Then GoTo Fin sbSrc1 = sbDest1 : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes If bDebugSplit Then Debug.WriteLine("Accents :") If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If Not Me.chkEspacesInsec.Checked Then EnleverEspInsec(sCheminFichier1, sbSrc1, sbDest1) : sbSrc1 = sbDest1 EnleverEspInsec(sCheminFichier2, sbSrc2, sbDest2) : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 'If bDebugSplit Then Debug.WriteLine("EspacesInsec :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If Not Me.chkEspaces.Checked Then ' 03/05/2014 EnleverEspaces(sCheminFichier1, sbSrc1, sbDest1) : sbSrc1 = sbDest1 EnleverEspaces(sCheminFichier2, sbSrc2, sbDest2) : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 'If bDebugSplit Then Debug.WriteLine("Espaces :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If Not Me.chkCasse.Checked Then If Not bEnleverMajuscules(sCheminFichier1, sbSrc1, sbDest1) Then GoTo Fin If Not bEnleverMajuscules(sCheminFichier2, sbSrc2, sbDest2) Then GoTo Fin sbSrc1 = sbDest1 : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 'If bDebugSplit Then Debug.WriteLine("Casse :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If Not Me.chkPonctuation.Checked Then ' Option Mots possible ssi on ignore la ponctuation Dim bOptionComparerMots As Boolean = Not Me.chkPhrases.Checked Dim bOptionComparerParag As Boolean = Me.chkParag.Checked Dim bOptionComparerNum As Boolean = Me.chkNum.Checked Dim sCheminDest1$ = "", sCheminDest2$ = "" If Not bEnleverPonctuation(sCheminFichier1, sbSrc1, sbDest1, bOptionComparerMots, bOptionComparerParag, bOptionComparerNum) Then GoTo Fin If Not bEnleverPonctuation(sCheminFichier2, sbSrc2, sbDest2, bOptionComparerMots, bOptionComparerParag, bOptionComparerNum) Then GoTo Fin sbSrc1 = sbDest1 : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 'If bDebugSplit Then Debug.WriteLine("Ponctuation :") 'If bDebugSplit Then Debug.WriteLine("Fichier n°1 : [" & sbSrc1.ToString & "]") 'If bDebugSplit Then Debug.WriteLine("Fichier n°2 : [" & sbSrc2.ToString & "]") End If If bEcriture Then sCheminFichier1 = Application.StartupPath & "\" & sFichier & "1" & sExtTxt sCheminFichier2 = Application.StartupPath & "\" & sFichier & "2" & sExtTxt ' Si on a demandé les infos avec tout coché, il faut lire une 1ère fois If iNbEcrituresTot = 0 Then 'sbDest1 = sbLireFichier(sCheminFichier1Orig) 'sbDest2 = sbLireFichier(sCheminFichier2Orig) ' 10/07/2022 sbDest1 = sbLireFichier(sCheminFichier1Orig, encod1) sbDest2 = sbLireFichier(sCheminFichier2Orig, encod2) End If If Not bEcrireFichiers(sbDest1, sbDest2, sCheminFichier1, sCheminFichier1Orig, sCheminFichier2, sCheminFichier2Orig, iIdxSrcOrig1, iIdxSrcOrig2, sbSrcOrig1, sbSrcOrig2, sEncodage1, sEncodage2) Then GoTo Fin End If ' Gestion WinDiff ou WinMerge If Not Me.chkWinDiff.Checked Then If m_sCheminWinMerge.Length = 0 Then If Not bLireCleBRWinMerge() Then GoTo Fin End If End If Const sGm$ = """" Dim sCmd$ = sGm & sCheminFichier1 & sGm & " " & sGm & sCheminFichier2 & sGm Dim p As New Process If Not Me.chkWinDiff.Checked Then ' 02/03/2014 p.StartInfo = New ProcessStartInfo(m_sCheminWinMerge) Else p.StartInfo = New ProcessStartInfo(sCheminWinDiff) End If p.StartInfo.Arguments = sCmd ' 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() Fin: ActivationCmdPage() Me.cmdComp.Enabled = True Me.cmdAnnuler.Enabled = False Sablier(bDesactiver:=True) ' 04/07/2022 End Sub Private Function bEcrireFichiers( ByRef sbPage1 As StringBuilder, ByRef sbPage2 As StringBuilder, sCheminSrc1$, sCheminSrcOrig1$, sCheminSrc2$, sCheminSrcOrig2$, iIdxSrcOrig1%, iIdxSrcOrig2%, sbSrc1Orig As StringBuilder, sbSrc2Orig As StringBuilder, sEncodage1$, sEncodage2$) As Boolean For iNumFichier As Integer = 1 To 2 Dim sCheminDest$ = Application.StartupPath & "\" & sFichier & iNumFichier & sExtTxt Dim sbPage As StringBuilder = sbPage1 Dim sbSrcOrig As StringBuilder = sbSrc1Orig Dim sCheminSrc$ = sCheminSrc1 Dim sSrcOrig$ = sCheminSrcOrig1 Dim iIdxSrcOrig% = iIdxSrcOrig1 Dim sEncodage$ = sEncodage1 If iNumFichier = 2 Then sbPage = sbPage2 sCheminSrc = sCheminSrc2 sSrcOrig = sCheminSrcOrig2 iIdxSrcOrig = iIdxSrcOrig2 sbSrcOrig = sbSrc2Orig sEncodage = sEncodage2 End If If Me.chkInfo.Checked Then Const bAfficherFichier As Boolean = True Dim bAfficherTailleFinale As Boolean = Not Me.chkParag.Checked Dim iNumPage% = m_iNumPage Dim iNbPages% = m_iNbPages If Not Me.chkPaginer.Checked Then iNumPage = 1 : iNbPages = 1 ' 12/01/2014 Dim sbDest As StringBuilder = Nothing If Not bAjouterInfo(iNumFichier, sCheminSrc, sSrcOrig, sEncodage, sbPage, sbSrcOrig, sbDest, iNumPage, iNbPages, iIdxSrcOrig, bAfficherFichier, bAfficherTailleFinale) Then Return False sbPage = sbDest End If ' 26/01/2014 Dim bFusionMC As Boolean = Not Me.chkParag.Checked If bFusionMC Then Dim sbDest As StringBuilder = Nothing FusionnerMotsCoupes(sbPage, sbDest, iNumFichier, sSrcOrig) sbPage = sbDest End If If Not bEcrireFichier(sCheminDest, sbPage) Then Return False If bDebug AndAlso Me.chkPaginer.Checked Then Dim sDest2$ = Application.StartupPath & "\" & sFichier & iNumFichier & "_" & sPage & Me.m_iNumPage & sExtTxt If Not bEcrireFichier(sDest2, sbPage) Then Return False End If Next Return True End Function #End Region #Region "Gestion des événements" Private Sub cmdComp_Click(sender As Object, e As EventArgs) _ Handles cmdComp.Click Comparer() End Sub Private Sub chkTout_Click(sender As Object, e As EventArgs) _ Handles chkTout.Click ' Tout implique les espaces inséc., la casse, les accents et la ponctuation, ' et vice versa : GererChkTout Me.chkEspacesInsec.Checked = Me.chkTout.Checked Me.chkEspaces.Checked = Me.chkTout.Checked Me.chkCasse.Checked = Me.chkTout.Checked Me.chkAccents.Checked = Me.chkTout.Checked Me.chkPonctuation.Checked = Me.chkTout.Checked Me.chkQuotes.Checked = Me.chkTout.Checked Me.chkNum.Checked = Me.chkTout.Checked Me.chkPhrases.Checked = Me.chkTout.Checked Me.chkParag.Checked = Me.chkTout.Checked GererActivationPhrasesEtParag() End Sub Private Sub GererChkTout() If Me.chkEspacesInsec.Checked AndAlso Me.chkEspaces.Checked AndAlso Me.chkCasse.Checked AndAlso Me.chkAccents.Checked AndAlso Me.chkPonctuation.Checked AndAlso Me.chkQuotes.Checked AndAlso Me.chkNum.Checked Then Me.chkTout.Checked = True Else Me.chkTout.Checked = False End If End Sub Private Sub chkEspacesInsec_Click(sender As Object, e As EventArgs) _ Handles chkEspacesInsec.Click ' La détection des espaces insécables ne fonctionne que si l'on conserve la ponctuation If Me.chkEspacesInsec.Checked Then Me.chkPonctuation.Checked = True GererChkTout() End Sub Private Sub chkEspaces_Click(sender As Object, e As EventArgs) _ Handles chkEspaces.Click ' La détection des espaces ne fonctionne que si l'on conserve la ponctuation If Me.chkEspaces.Checked Then Me.chkPonctuation.Checked = True GererChkTout() End Sub Private Sub chkCasse_Click(sender As Object, e As EventArgs) Handles chkCasse.Click GererChkTout() End Sub Private Sub chkAccents_Click(sender As Object, e As EventArgs) Handles chkAccents.Click GererChkTout() End Sub Private Sub chkQuotes_Click(sender As Object, e As System.EventArgs) Handles chkQuotes.Click GererChkTout() End Sub Private Sub chkNum_Click(sender As Object, e As EventArgs) Handles chkNum.Click ' La possibilité d'ignorer les numériques ne fonctionne que si ' l'on retire la ponctuation et que l'on compare mot à mot If Not Me.chkNum.Checked Then _ Me.chkPonctuation.Checked = False : Me.chkPhrases.Checked = False GererChkTout() End Sub Private Sub chkPonctuation_Click(sender As Object, e As EventArgs) _ Handles chkPonctuation.Click GererChkTout() End Sub Private Sub chkPonctuation_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPonctuation.CheckedChanged GererActivationPhrasesEtParag() End Sub Private Sub GererActivationPhrasesEtParag() ' L'option de découpage des phrases en mots n'est possible que si on ignore la ponctuation ' donc si on coche la ponctuation, on doit désactiver le découpage en mots (chkPhrases = True) If Me.chkPonctuation.Checked AndAlso Not Me.chkPhrases.Checked Then _ Me.chkPhrases.Checked = True ' Pareil pour les paragraphes If Me.chkPonctuation.Checked AndAlso Not Me.chkParag.Checked Then _ Me.chkParag.Checked = True ' Pareil pour les numériques 03/06/2018 If Me.chkPonctuation.Checked AndAlso Not Me.chkNum.Checked Then _ Me.chkNum.Checked = True End Sub Private Sub chkPhrases_Click(sender As Object, e As EventArgs) _ Handles chkPhrases.Click ' Si on compare mot à mot, alors décocher la ponctuation ' (car le mode mot à mot est lancé uniquement dans ce cas) If Not Me.chkPhrases.Checked AndAlso Me.chkPonctuation.Checked Then _ Me.chkPonctuation.Checked = False ' 04/01/2014 Sens unique ' 03/06/2018 Si on coche les phrases, on ne peut pas ignorer les numériques If Me.chkPhrases.Checked Then Me.chkNum.Checked = True End Sub Private Sub chkPhrases_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPhrases.CheckedChanged ActivationCmdPage() End Sub Private Sub chkParag_Click(sender As Object, e As EventArgs) Handles chkParag.Click ' Si on ignore les paragraphes dans le mode mot à mot, alors décocher la ponctuation ' (car le mode mot à mot est lancé uniquement dans ce cas) If Not Me.chkParag.Checked AndAlso Me.chkPonctuation.Checked Then _ Me.chkPonctuation.Checked = False : Me.chkPhrases.Checked = False End Sub 'Private Sub chkParag_CheckedChanged(sender As Object, e As EventArgs) Handles chkParag.CheckedChanged 'End Sub Private Sub chkPaginer_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPaginer.CheckedChanged ActivationCmdPage() End Sub Private Sub cmdPagePreced_Click(sender As Object, e As EventArgs) _ Handles cmdPagePreced.Click Me.m_iNumPage -= 1 ActivationCmdPage() If Me.m_iNumPage = 1 Then Me.cmdPageSuiv.Select() End Sub Private Sub cmdPageSuiv_Click(sender As Object, e As EventArgs) _ Handles cmdPageSuiv.Click Me.m_iNumPage += 1 ActivationCmdPage() If Me.m_iNumPage = Me.m_iNbPages Then Me.cmdPagePreced.Select() End Sub Private Sub ActivationCmdPage() If Me.chkPaginer.Checked Then Me.cmdPagePreced.Enabled = (Me.m_iNumPage > 1) Me.cmdPageSuiv.Enabled = (Me.m_iNumPage < Me.m_iNbPages) Me.lblNumPage.Enabled = True Me.chkRatio.Enabled = True Else Me.lblNumPage.Enabled = False Me.cmdPagePreced.Enabled = False Me.cmdPageSuiv.Enabled = False Me.chkRatio.Enabled = False End If Me.lblNumPage.Text = Me.m_iNumPage & "/" & Me.m_iNbPages End Sub Private Sub chkWinDiff_Click(sender As Object, e As System.EventArgs) Handles chkWinDiff.Click PresicerInfoBullesWinDiff() End Sub Private Sub PresicerInfoBullesWinDiff() If Not Me.chkWinDiff.Checked AndAlso bLireCleBRWinMerge() Then Me.ToolTip1.SetToolTip(Me.chkWinDiff, "Décoché : Lancer WinMerge (sinon WinDiff)") Else If m_sCheminWinMerge.Length > 0 Then Me.ToolTip1.SetToolTip(Me.chkWinDiff, "Coché : Lancer WinDiff (sinon WinMerge)") Else Me.ToolTip1.SetToolTip(Me.chkWinDiff, "Lancer WinDiff (sinon effectuer simplement les traitements)") End If End If End Sub Private Function bLireCleBRWinMerge() As Boolean Dim sCheminWinMerge$ = "" If Not bCleRegistreCUExiste("SOFTWARE\Thingamahoochie\WinMerge", "Executable", sCheminWinMerge) Then Return False ' Par défaut : "C:\Program Files\WinMerge\WinMergeU.exe" m_sCheminWinMerge = sCheminWinMerge If m_sCheminWinMerge.Length = 0 Then Return False If Not bFichierExiste(m_sCheminWinMerge, bPrompt:=True) Then Return False Return True End Function #End Region #Region "Gestion du raccourci" Private m_sCheminRaccourci$ = Environment.GetFolderPath(Environment.SpecialFolder.SendTo) & "\" & sLienExeVBWinDiff Private Sub VerifierRaccourci() If bFichierExiste(m_sCheminRaccourci) Then Me.cmdAjouterRaccourci.Enabled = False Me.cmdEnleverRaccourci.Enabled = True Else Me.cmdAjouterRaccourci.Enabled = True Me.cmdEnleverRaccourci.Enabled = False End If End Sub Private Sub cmdAjouterRaccourci_Click(sender As Object, e As EventArgs) _ Handles cmdAjouterRaccourci.Click Dim sLien$ = m_sCheminRaccourci Dim sCibleFinale$ = Application.StartupPath & "\" & sExeVBWinDiff CreerRaccourci(sLien, sCibleFinale) VerifierRaccourci() End Sub Private Sub cmdEnleverRaccourci_Click(sender As Object, e As EventArgs) _ Handles cmdEnleverRaccourci.Click If Not bFichierExiste(m_sCheminRaccourci) Then Exit Sub If Not bSupprimerFichier(m_sCheminRaccourci) Then Exit Sub VerifierRaccourci() End Sub #End Region End Class modConst.vb Module modConst #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If Public Const sExtTxt$ = ".txt" Public Const sFusion$ = "Fusion" Public Const sFichier$ = "Fichier" Public Const sPage$ = "Page" Public Const sOrig$ = "Orig" 'Public Const sFiltrePages$ = "Fichier?_Page?.txt" Public Const sFiltreTmp$ = "Fichier?_*" & sExtTxt Public Const sFiltreFusion$ = sFusion & "?" & sExtTxt Public Const sListeSeparateursPhrase$ = ".:?!;|¡¿" ' Normalisation des quotes Public Const iCodeASCIIGuillemet% = 34 ' " Public Const iCodeASCIIGuillemetOuvrant% = 171 ' « ' Rétabli le 18/11/2018 Public Const iCodeASCIIGuillemetFermant% = 187 ' » ' Rétabli le 18/11/2018 Public Const iCodeASCIIGuillemetOuvrant3% = 147 ' “ Public Const iCodeASCIIGuillemetFermant3% = 148 ' ” Public Const iCodeASCIIQuote% = 39 ' Public Const iCodeASCIIQuote2% = 27 ' Public Const iCodeASCIIGuillemetOuvrant2% = 145 ' ‘ Public Const iCodeASCIIGuillemetFermant2% = 146 ' ’ 'Public Const iCodeASCIIGuillemetOuvrant4% = 96 ' ` Public Const iCodeASCIIGuillemetFermant4% = 180 ' ´ Public Const iCodeASCIIEspaceInsecable% = 160 ' Non-breaking space Public Const iCodeUTF16EspaceFineInsecable% = 8239 ' Alt+8239 = 0x202F = espace fine insécable Public Const iCodeASCIITiretMoyen% = 150 ' – Public Const iIndiceNulString% = -1 End Module modDepart.vb ' Fichier modDepart.vb ' -------------------- Module modDepart Public ReadOnly sNomAppli$ = My.Application.Info.Title Public ReadOnly sTitreMsg$ = sNomAppli Public m_sTitreMsg$ = sTitreMsg Public Const sTitreMsgDescription$ = " : Interface d'options pour le comparateur WinDiff et WinMerge" Public Const sDateVersionAppli$ = "04/08/2024" Public ReadOnly sVersionAppli$ = My.Application.Info.Version.Major & "." & My.Application.Info.Version.Minor & My.Application.Info.Version.Build 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 Levé (Thrown) dans le menu Déboguer:Exceptions... 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, ' sinon utiliser l'attribut de fonction <System.Diagnostics.DebuggerStepThrough()> 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, "Depart " & sTitreMsg) End Try End Sub Public Sub Depart() ' On peut démarrer l'application sur la feuille, ou bien sur la procédure ' Main() si on veut pouvoir détecter l'absence de la dll sans plantage ' Extraire les options passées en argument de la ligne de commande ' Cette fct ne marche pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command Dim sCheminFichier1$ = "" Dim sCheminFichier2$ = "" 'Dim iTypeComp As frmVBWinDiff.TypeComp = frmVBWinDiff.TypeComp.xxx Dim bSyntaxeOk As Boolean = False Dim iNbArguments% = 0 If sArg0 <> "" Then Dim asArgs$() = asArgLigneCmd(sArg0) iNbArguments = UBound(asArgs) + 1 If iNbArguments = 2 Then bSyntaxeOk = True If Not bSyntaxeOk Then GoTo Suite sCheminFichier1 = asArgs(0) If Not bFichierExiste(sCheminFichier1, bPrompt:=True) Then _ bSyntaxeOk = False : GoTo Suite sCheminFichier2 = asArgs(1) If Not bFichierExiste(sCheminFichier2, bPrompt:=True) Then _ bSyntaxeOk = False End If Suite: If bRelease And Not bSyntaxeOk Then MsgBox( "Syntaxe : Chemin des deux fichiers textes à comparer" & vbCrLf & "Sinon ajouter le raccourci via le menu dédié suivant" & vbCrLf & " et envoyer deux fichiers à comparer vers VBWinDiff" & vbCrLf & " via l'explorateur de fichier de Windows.", MsgBoxStyle.Information, sTitreMsg & sTitreMsgDescription) If iNbArguments > 0 Then Exit Sub End If Dim oFrm As New frmVBWinDiff oFrm.m_sCheminFichier1 = sCheminFichier1 oFrm.m_sCheminFichier2 = sCheminFichier2 'oFrm.m_iTypeConv = iTypeConv Application.Run(oFrm) End Sub End Module modUtil.vb ' Fichier modUtil.vb ' ------------------ Module modUtil 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 Sablier(Optional ByRef bDesactiver As Boolean = False) If bDesactiver Then Cursor.Current = Cursors.Default Else Cursor.Current = Cursors.WaitCursor End If End Sub Public Sub CopierPressePapier(sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", bCopierMsgPressePapier:=False) End Try End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub Public Sub LibererRessourceDotNet() GC.Collect() GC.WaitForPendingFinalizers() TraiterMsgSysteme_DoEvents() End Sub End Module modVBWinDiff.vb 'Imports System.Text.Encoding ' Pour GetEncoding Imports System.Text ' Pour StringBuilder Imports System.Text.RegularExpressions ' Pour Regex Module modVBWinDiff #Region "Classes page et mot" Public Class clsPage Public iIndexSrc% = 0 ' Index de départ dans le texte d'origine Public sbPage As StringBuilder Public Sub New(iIndexSrc0%, sbPage0 As StringBuilder) iIndexSrc = iIndexSrc0 sbPage = sbPage0 End Sub End Class Public Class clsMot Public sMotConcat$, sMot1$, sMot2$ Public iNbOccConcat%, iNbOcc1%, iNbOcc2% End Class #End Region Public Function bEnleverAccents(sSrc$, ByRef sbSrc As StringBuilder, ByRef sbDest As StringBuilder, bMinuscule As Boolean) As Boolean If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) If IsNothing(sbDest) Then sbDest = New StringBuilder sbDest = sbEnleverAccents(sbSrc, bMinuscule) bEnleverAccents = True End Function Private Sub LireInfoFichier(sCheminFichier$, ByRef sTaille$, ByRef sDate$, ByRef lTaille&) Dim fi As New IO.FileInfo(sCheminFichier) lTaille = fi.Length Dim sTailleFichier$ = sFormaterTailleOctets(lTaille) Dim sTailleFichierDetail$ = sFormaterTailleOctets(lTaille, bDetail:=True) ' Attention à l'heure de la date : l'explorateur de Windows XP ' enlève 1 heure si l'on est passé à l'heure d'hiver depuis la date à afficher ' c'est n'importe quoi ! ' Heureusement fi.LastWriteTime affiche toujours la bonne heure (et la même heure) sTaille = sTailleFichierDetail sDate = fi.LastWriteTime.ToString End Sub Public Function bAjouterInfo(iNumFichier%, sSrc$, sSrcOrig$, sEncodage$, ByRef sbSrc As StringBuilder, ByRef sbSrcOrig As StringBuilder, ByRef sbDest As StringBuilder, Optional iNumPage% = 0, Optional iNbPages% = 0, Optional iIdxSrcOrig% = -1, Optional bAfficherFichier As Boolean = True, Optional bAfficherTailleFinale As Boolean = False) As Boolean If IsNothing(sbSrc) Then If bDebug Then Stop Return False End If If IsNothing(sbSrcOrig) Then If bDebug Then Stop Return False End If If IsNothing(sbDest) Then sbDest = New StringBuilder Dim sTailleFichier$ = "", sDateFichier$ = "" Dim lTailleFichier& = 0 LireInfoFichier(sSrcOrig, sTailleFichier, sDateFichier, lTailleFichier) Dim sbTmp As New StringBuilder ' Mettre le fichier en 1er, car le dossier sera tjrs le même If bAfficherFichier Then sbTmp.AppendLine("Fichier n°" & iNumFichier & " : " & IO.Path.GetFileName(sSrcOrig) & " : " & IO.Path.GetDirectoryName(sSrcOrig)) sbTmp.AppendLine("Taille = " & sTailleFichier & ", Date = " & sDateFichier) End If If iNbPages > 1 Then sbTmp.AppendLine("Page " & iNumPage & "/" & iNbPages) ' Afficher la taille de la page en octets : ' Section = [octet de départ - octet de fin] Dim iTaillePage% = 0 Dim lLong& = 0 If iIdxSrcOrig > lTailleFichier Then If bDebug Then Stop End If lLong = iIdxSrcOrig + sbSrcOrig.Length If lLong > lTailleFichier Then Stop sbTmp.Append("Section = [" & iIdxSrcOrig & " - " & lLong & "[") iTaillePage = CInt(lLong - iIdxSrcOrig) If sbSrcOrig.Length > iTaillePage Then If bDebug Then Stop End If sbTmp.Append(" : " & sFormaterTailleOctets(iTaillePage, bDetail:=True)) ' Total déjà découpé : sbTmp.Append(" : " & sFormaterTailleOctets(lLong, bDetail:=True)) ' Pourcentage déjà découpé : Dim rPC! = CSng(lLong / lTailleFichier) sbTmp.Append(" : " & rPC.ToString("0.00%")) sbTmp.Append(vbCrLf) End If ' 26/01/2014 Si on décoche l'option Paragraphe, alors afficher la taille finale ' après les traitements, pour vérifier rapidement si les textes sont de même ' longueur (si on ne compare que les mots sans les sauts de ligne par ex.) If bAfficherTailleFinale Then Dim lTailleFinale& = sbSrc.Length Dim sTailleFinale$ = sFormaterTailleOctets(lTailleFinale, bDetail:=True) sbTmp.AppendLine("Taille finale = " & sTailleFinale) End If ' 10/07/2022 sbTmp.AppendLine("Encodage = " & sEncodage) sbDest = sbTmp.Append(sbSrc) bAjouterInfo = True End Function Public Function bPaginerFichiers(sCheminFichier1$, sCheminFichier2$, iTaillePage%, ByRef iNbPages%, ByRef dico1Pages As Dictionary(Of Integer, clsPage), ByRef dico2Pages As Dictionary(Of Integer, clsPage), bAppliquerRatio As Boolean, encodage1 As Encoding, encodage2 As Encoding) As Boolean Dim sbSrc1 As StringBuilder = sbLireFichier(sCheminFichier1, encodage1) Dim sbSrc2 As StringBuilder = sbLireFichier(sCheminFichier2, encodage2) Dim iLongSrc1% = sbSrc1.Length Dim iLongSrc2% = sbSrc2.Length Dim iLongMax12% = 0 Dim bLongMax2 As Boolean = False If iLongSrc1 > iLongMax12 Then iLongMax12 = iLongSrc1 If iLongSrc2 >= iLongMax12 Then iLongMax12 = iLongSrc2 : bLongMax2 = True If Not bLongMax2 Then If bDebug Then Stop ' Ce n'est plus possible grâce à la permutation des 2 fichiers End If iNbPages = CInt(iLongMax12 \ CLng(iTaillePage)) Dim lReste& = iLongMax12 Mod iTaillePage If lReste > 0 Then iNbPages += 1 Dim rRatio! = 1.0! If bAppliquerRatio AndAlso iLongSrc1 > 0 Then rRatio = CSng(iLongSrc2 / iLongSrc1) End If dico1Pages = New Dictionary(Of Integer, clsPage) dico2Pages = New Dictionary(Of Integer, clsPage) Dim iCumulPage1% = 0 Dim iCumulPage2% = 0 Dim iNumPage% For iNumPage = 0 To iNbPages - 1 ' Pagination Dim iLong1% = iTaillePage Dim iLong2% = iTaillePage If bAppliquerRatio Then iLong1 = CInt(iLong1 / rRatio) ' Gestion de l'arrondi If iNumPage = iNbPages - 1 AndAlso iCumulPage1 + iLong1 < iLongSrc1 Then iLong1 = iLongSrc1 - iCumulPage1 End If End If Dim iIdxSrc1% = iCumulPage1 Dim iIdxSrc2% = iCumulPage2 Dim sbDestPage1 As StringBuilder = Nothing Paginer(iIdxSrc1, iLong1, sbSrc1, sbDestPage1) dico1Pages.Add(iNumPage, New clsPage(iIdxSrc1, sbDestPage1)) Dim sbDestPage2 As StringBuilder = Nothing Paginer(iIdxSrc2, iLong2, sbSrc2, sbDestPage2) dico2Pages.Add(iNumPage, New clsPage(iIdxSrc2, sbDestPage2)) Dim iLongDest1% = sbDestPage1.Length Dim iLongDest2% = sbDestPage2.Length iCumulPage1 += iLongDest1 iCumulPage2 += iLongDest2 'Debug.WriteLine("Page n°" & iNumPage + 1 & " :") 'Debug.WriteLine("Fichier 1 : " & iLongDest1 & " : " & iCumulPage1 & "/" & iLongSrc1) 'Debug.WriteLine("Fichier 2 : " & iLongDest2 & " : " & iCumulPage2 & "/" & iLongSrc2) Next Return True End Function Private Sub Paginer(iIdxSrc%, iTailleTroncon%, sbSrc As StringBuilder, ByRef sbDestPage As StringBuilder) Dim iLongSb% = sbSrc.Length Dim iMemTailleTroncon% = iTailleTroncon If iIdxSrc + iMemTailleTroncon > iLongSb Then iTailleTroncon = iLongSb - iIdxSrc If iTailleTroncon < 0 Then iTailleTroncon = 0 If iIdxSrc > iLongSb Then ' De toute façon, le fichier sera vide ici (iLong = 0) ' c'est juste pour éviter un dépassement iIdxSrc = iLongSb End If End If End If Dim ac As Char() = Nothing ReDim ac(0 To iTailleTroncon - 1) sbSrc.CopyTo(iIdxSrc, ac, 0, iTailleTroncon) sbDestPage = New StringBuilder For Each cCar As Char In ac sbDestPage.Append(cCar) Next End Sub Public Sub EnleverEspInsec(sSrc$, ByRef sbSrc As StringBuilder, ByRef sbDest As StringBuilder) If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) sbDest = sbSrc.Replace(Chr(iCodeASCIIEspaceInsecable), " "c) sbDest = sbSrc.Replace(ChrW(iCodeUTF16EspaceFineInsecable), " "c) ' 15/09/2018 ' 05/07/2024 Remplacer les tirets moyens (–) par des tirets courts (-) sbDest = sbSrc.Replace(" " & Chr(iCodeASCIITiretMoyen) & " ", " - ") sbDest = sbSrc.Replace(Chr(iCodeASCIITiretMoyen) & " ", "- ") sbDest = sbSrc.Replace(" " & Chr(iCodeASCIITiretMoyen), " -") End Sub Public Sub EnleverEspaces(sSrc$, ByRef sbSrc As StringBuilder, ByRef sbDest As StringBuilder) If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) sbDest = New StringBuilder ' Découpage par paragraphe Dim asParag$() = sbSrc.ToString.Split(CChar(vbCrLf)) For Each sParag As String In asParag Dim sParagTrim$ = sParag.Trim ' 12/12/2015 Supprimer les doubles saut de ligne si on coche Espace If String.IsNullOrEmpty(sParagTrim) Then Continue For sbDest.AppendLine(sParagTrim) Next End Sub Public Function bEnleverMajuscules(sSrc$, ByRef sbSrc As StringBuilder, ByRef sbDest As StringBuilder) As Boolean If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) sbDest = New StringBuilder sbDest.Append(sbSrc.ToString.ToLower) bEnleverMajuscules = True End Function Public Function bEnleverPonctuation(sSrc$, ByRef sbSrc As StringBuilder, ByRef sbDest As StringBuilder, bOptionComparerMots As Boolean, bOptionComparerParag As Boolean, bOptionComparerNum As Boolean) As Boolean If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) sbDest = New StringBuilder ' Ne marche pas : 'sbDest.Append(sbSrc.Replace("-;".ToCharArray, "")) ' Rechercher tous les mots de la chaine : \w+ Const sRechMots$ = "\w+" ' Découpage par phrase Dim bSupprDblSautDeLignes As Boolean = Not bOptionComparerParag 'Const bOptionComparerMots As Boolean = True Dim acSepPhrase() As Char = sListeSeparateursPhrase.ToCharArray Dim asParag$() = sbSrc.ToString.Split(CChar(vbCrLf)) Const bDebugSplit As Boolean = False If bDebugSplit Then Debug.WriteLine("-[" & sbSrc.ToString & "]-") Dim bSautDejaFait As Boolean = False Dim iNumParag% = 0 For Each sParag As String In asParag iNumParag += 1 If bDebugSplit Then Debug.WriteLine("Parag. n°" & iNumParag & " : [" & sParag & "]") 'Dim bParagVide As Boolean 'bParagVide = False If sParag.Length = 0 Then Continue For 'If sParag.Length = 0 Then bParagVide = True : GoTo ParagSuiv 'Dim bSautDeParagDejaFait As Boolean 'bSautDeParagDejaFait = False 'Dim c As Char = sParag.Chars(0) 'If c = vbLf Then ' If bDebugSplit Then Debug.WriteLine("vbLf") ' sbDest.Append(vbCrLf) ' bSautDeParagDejaFait = True 'End If Dim asPhrases$() = sParag.Split(acSepPhrase) Dim iNumPhrase% = 0 For Each sPhrase As String In asPhrases iNumPhrase += 1 'Dim bPhraseVide As Boolean 'bPhraseVide = False If sPhrase.Length = 0 Then Continue For 'If sPhrase.Length = 0 Then bPhraseVide = True : GoTo PhraseSuiv ' 26/11/2021 Si une phrase ne contient qu'un " alors ignorer Dim iLen% = sPhrase.Length If iLen = 1 Then Dim c1 As Char = sPhrase.Chars(0) If Asc(c1) = iCodeASCIIGuillemet Then Continue For End If Dim matches As MatchCollection = Regex.Matches(sPhrase, sRechMots) For i As Integer = 0 To matches.Count - 1 bSautDejaFait = False Dim sMot$ = matches(i).ToString ' 19/01/2018 If Not bOptionComparerNum AndAlso bOptionComparerMots AndAlso IsNumeric(sMot) Then bSautDejaFait = True ' Eviter un saut de ligne, puisque le mot est ignoré Continue For End If sbDest.Append(sMot) If bOptionComparerMots Then sbDest.Append(vbCrLf) bSautDejaFait = True Else sbDest.Append(" ") End If Next 'PhraseSuiv: If Not bSupprDblSautDeLignes OrElse Not bSautDejaFait Then sbDest.Append(vbCrLf) Next 'ParagSuiv: If Not bSupprDblSautDeLignes OrElse Not bSautDejaFait Then sbDest.Append(vbCrLf) Next bEnleverPonctuation = True End Function Public Sub FusionnerMotsCoupes(sbMotsSrc As StringBuilder, ByRef sbMotsDest As StringBuilder, iNumFichier%, sCheminSrcOrig$) ' Fusionner les mots coupés éventuels dans la mesure où ' un mot concaténé est plus fréquent que chacun des tronçons Dim sb As New StringBuilder() Const bDebug0 As Boolean = False If bDebug0 Then Debug.WriteLine("") Debug.WriteLine("Fusion du fichier :" & sbMotsSrc.Length) End If sbMotsDest = New StringBuilder Dim asLignes$() = sbMotsSrc.ToString.Split(CChar(vbCrLf)) Dim dico As New Dictionary(Of String, Integer) ' sClé : sMot -> iNbMots ' Compter la fréquence de chaque mot For Each sMot As String In asLignes Dim sMot2$ = sMot.Trim If dico.ContainsKey(sMot2) Then dico(sMot2) += 1 Else dico(sMot2) = 1 End If Next ' Vérifier si un mot concaténé avec le suivant est plus fréquent Dim dicoVerif As New DicoTri(Of String, clsMot) ' sClé : sMotConcat -> clsMot Dim iNbMots% = asLignes.GetUpperBound(0) Dim iNumMot% = 0 Dim bFusion As Boolean = False Do While iNumMot < iNbMots bFusion = False Dim sMot$ = asLignes(iNumMot).Trim Dim sMotSuiv$ = asLignes(iNumMot + 1).Trim If sMot.Length <= 1 OrElse sMotSuiv.Length <= 1 Then sbMotsDest.AppendLine(sMot) GoTo MotSuivant End If Dim sMotConcat$ = sMot & sMotSuiv Dim iNbOccMot% = dico(sMot) Dim iNbOccMotSuiv% = dico(sMotSuiv) If Not dico.ContainsKey(sMotConcat) Then sbMotsDest.AppendLine(sMot) GoTo MotSuivant End If Dim iNbOccMotConcat% = dico(sMotConcat) If iNbOccMot < iNbOccMotConcat AndAlso iNbOccMotSuiv < iNbOccMotConcat Then If bDebug0 Then _ Debug.WriteLine("Mot coupé potentiel : " & sMotConcat & "(" & iNbOccMotConcat & ") " & sMot & "(" & iNbOccMot & ") " & sMotSuiv & "(" & iNbOccMotSuiv & ")") sbMotsDest.AppendLine(sMotConcat) Dim mot As New clsMot mot.sMotConcat = sMotConcat mot.iNbOccConcat = iNbOccMotConcat mot.sMot1 = sMot : mot.iNbOcc1 = iNbOccMot mot.sMot2 = sMotSuiv : mot.iNbOcc2 = iNbOccMotSuiv If dicoVerif.ContainsKey(sMotConcat) Then ' Conserver la taille max. Dim mot0 As clsMot = dicoVerif(sMotConcat) If iNbOccMotConcat > mot0.iNbOccConcat Then mot0.iNbOccConcat = iNbOccMotConcat Else dicoVerif.Add(sMotConcat, mot) End If iNumMot += 1 bFusion = True Else sbMotsDest.AppendLine(sMot) End If MotSuivant: iNumMot += 1 Loop ' Ajouter le dernier mot le cas échéant If Not bFusion Then Dim sMot$ = asLignes(iNumMot).Trim If sMot.Length > 0 Then sbMotsDest.AppendLine(sMot) End If 'If Not bDebug0 Then Exit Sub If bDebug0 Then Debug.WriteLine("") Debug.WriteLine("Tri par fréquence décroissante :") End If For Each mot As clsMot In dicoVerif.Trier( "iNbOccConcat DESC, iNbOcc1 DESC, iNbOcc2 DESC, sMotConcat") If bDebug0 Then _ Debug.WriteLine("Mot coupé potentiel : " & mot.sMotConcat & "(" & mot.iNbOccConcat & ") " & mot.sMot1 & "(" & mot.iNbOcc1 & ") " & mot.sMot2 & "(" & mot.iNbOcc2 & ")") If sb.Length = 0 Then sb.AppendLine("Fusion du fichier " & iNumFichier & " : " & sCheminSrcOrig) sb.AppendLine("(Occurrences du mot fusionné : occurrences du tronçon de début-occurrences du tronçon de fin)") End If sb.AppendLine(mot.sMotConcat & " : " & mot.sMot1 & "-" & mot.sMot2 & " (" & mot.iNbOccConcat & " : " & mot.iNbOcc1 & "-" & mot.iNbOcc2 & ")") Next Dim sCheminRapportFusion$ = Application.StartupPath & "\" & sFusion & iNumFichier & sExtTxt Dim sCheminRapportOrig$ = Application.StartupPath & "\" & sFichier & iNumFichier & "_" & sOrig & sExtTxt If sb.Length = 0 Then bSupprimerFichier(sCheminRapportFusion) bSupprimerFichier(sCheminRapportOrig) Exit Sub End If bEcrireFichier(sCheminRapportFusion, sb) bEcrireFichier(sCheminRapportOrig, sbMotsSrc) End Sub Public Sub NormaliserQuotes(sbSrc As StringBuilder, ByRef sbDest As StringBuilder) Dim sSepQuote$ = Chr(iCodeASCIIQuote) Dim sSepQuote2$ = Chr(iCodeASCIIQuote2) Dim sSepGmO2$ = Chr(iCodeASCIIGuillemetOuvrant2) ' ‘ ' 23/11/2014 Dim sSepGmF2$ = Chr(iCodeASCIIGuillemetFermant2) ' ’ Dim sSepGmF4$ = Chr(iCodeASCIIGuillemetFermant4) ' ´ ' 18/11/2018 Dans ce cas, il doit y avoir un espace aussi ' Solution possible : commencer par remplacer avec espace (l'espace sera supprimé), ' puis sans espace (tester aussi l'espace insécable et l'espace fine insécable) Dim sSepGmO1$ = Chr(iCodeASCIIGuillemetOuvrant) ' « Dim sSepGmF1$ = Chr(iCodeASCIIGuillemetFermant) ' » Dim sSepGmO1E$ = sSepGmO1 & " " Dim sSepGmF1E$ = " " & sSepGmF1 Dim sEspInsec$ = Chr(iCodeASCIIEspaceInsecable) Dim sEspInsecF$ = ChrW(iCodeUTF16EspaceFineInsecable) Dim sSepGmO1EI$ = sSepGmO1 & sEspInsec Dim sSepGmF1EI$ = sEspInsec & sSepGmF1 Dim sSepGmO1EFI$ = sSepGmO1 & sEspInsecF Dim sSepGmF1EFI$ = sEspInsecF & sSepGmF1 ' 20/07/2014 Dim sSepGuill$ = Chr(iCodeASCIIGuillemet) ' " Dim sSepGmO3$ = Chr(iCodeASCIIGuillemetOuvrant3) ' “ Dim sSepGmF3$ = Chr(iCodeASCIIGuillemetFermant3) ' ” sbDest = sbSrc.Replace(sSepQuote2, sSepQuote). Replace(sSepGmO2, sSepQuote).Replace(sSepGmF2, sSepQuote). Replace(sSepGmO3, sSepGuill).Replace(sSepGmF3, sSepGuill). Replace(sSepGmF4, sSepQuote). Replace(sSepGmO1EFI, sSepGuill).Replace(sSepGmF1EFI, sSepGuill). Replace(sSepGmO1EI, sSepGuill).Replace(sSepGmF1EI, sSepGuill). Replace(sSepGmO1E, sSepGuill).Replace(sSepGmF1E, sSepGuill). Replace(sSepGmO1, sSepGuill).Replace(sSepGmF1, sSepGuill) ' 18/11/2018 'Dim sDest$ = sbDest.ToString 'Dim iLong% = sDest.Length - 1 'Debug.WriteLine(sDest) 'Debug.WriteLine("Ouvrant : " & sDest.Chars(0) & " = " & Asc(sDest.Chars(0))) 'Debug.WriteLine("Fermant : " & sDest.Chars(iLong) & " = " & Asc(sDest.Chars(iLong))) End Sub End Module clsDicoTri.vb ' Classe Dictionary triable Imports System.Runtime.Serialization <Serializable> Public Class DicoTri(Of TKey, TValue) : Inherits Dictionary(Of TKey, TValue) Sub New() End Sub Protected Sub New(info As SerializationInfo, context As StreamingContext) MyBase.New(info, context) End Sub Public Function Trier(Optional sOrdreTri$ = "") As TValue() ' Trier la Dico et renvoyer le tableau des éléments triés If String.IsNullOrEmpty(sOrdreTri) Then sOrdreTri = "" Dim iNbLignes% = Me.Count Dim arrayTvalue(iNbLignes - 1) As TValue Dim iNumLigne% = 0 For Each line As KeyValuePair(Of TKey, TValue) In Me arrayTvalue(iNumLigne) = line.Value iNumLigne += 1 Next ' Si pas de tri demandé, retourner simplement le tableau tel quel If sOrdreTri.Length = 0 Then Return arrayTvalue ' Tri des éléments Dim comp As New UniversalComparer(Of TValue)(sOrdreTri) Array.Sort(Of TValue)(arrayTvalue, comp) Return arrayTvalue End Function End Class modEncodage.vb ' https://github.com/AutoItConsulting/text-encoding-detect ' Copyright 2015-2016 Jonathan Bennett <jon@autoitscript.com> ' ' https://www.autoitscript.com ' ' Licensed under the Apache License, Version 2.0 (the "License"); ' you may not use this file except in compliance with the License. ' You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' ' Unless required by applicable law or agreed to in writing, software ' distributed under the License is distributed on an "AS IS" BASIS, ' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ' See the License for the specific language governing permissions and ' limitations under the License. Option Infer On 'Namespace AutoIt.Common Public Class TextEncodingDetect Private ReadOnly _utf16BeBom As Byte() = {&HFE, &HFF} Private ReadOnly _utf16LeBom As Byte() = {&HFF, &HFE} Private ReadOnly _utf8Bom As Byte() = {&HEF, &HBB, &HBF} Private _nullSuggestsBinary As Boolean = True Private _utf16ExpectedNullPercent As Double = 70 Private _utf16UnexpectedNullPercent As Double = 10 Public Enum Encoding ''' <summary> ''' Unknown or binary ''' </summary> None ''' <summary> ''' 0-255 ''' </summary> Ansi ''' <summary> ''' 0-127 ''' </summary> Ascii ''' <summary> ''' UTF8 with BOM ''' </summary> Utf8Bom ''' <summary> ''' UTF8 without BOM ''' </summary> Utf8Nobom ''' <summary> ''' UTF16 LE (Little Endian) with BOM : Unicode ''' </summary> Utf16LeBom ''' <summary> ''' UTF16 LE (Little Endian) without BOM : Unicode ''' </summary> Utf16LeNoBom ''' <summary> ''' UTF16-BE (Big Endian) with BOM ''' </summary> Utf16BeBom ''' <summary> ''' UTF16-BE (Big Endian) without BOM ''' </summary> Utf16BeNoBom End Enum ''' <summary> ''' Sets if the presence of nulls in a buffer indicate the buffer is binary data rather than text. ''' </summary> Public WriteOnly Property NullSuggestsBinary As Boolean Set(ByVal value As Boolean) _nullSuggestsBinary = value End Set End Property Public WriteOnly Property Utf16ExpectedNullPercent As Double Set(ByVal value As Double) If value > 0 AndAlso value < 100 Then _utf16ExpectedNullPercent = value End If End Set End Property Public WriteOnly Property Utf16UnexpectedNullPercent As Double Set(ByVal value As Double) If value > 0 AndAlso value < 100 Then _utf16UnexpectedNullPercent = value End If End Set End Property ''' <summary> ''' Gets the BOM length for a given Encoding mode. ''' </summary> ''' <param name="encoding"></param> ''' <returns>The BOM length.</returns> Public Shared Function GetBomLengthFromEncodingMode(ByVal encoding As Encoding) As Integer Dim length As Integer Select Case encoding Case Encoding.Utf16BeBom, Encoding.Utf16LeBom length = 2 Case Encoding.Utf8Bom length = 3 Case Else length = 0 End Select Return length End Function ''' <summary> ''' Checks for a BOM sequence in a byte buffer. ''' </summary> ''' <param name="buffer"></param> ''' <param name="size"></param> ''' <returns>Encoding type or Encoding.None if no BOM.</returns> Public Function CheckBom(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' Check for BOM If size >= 2 AndAlso buffer(0) = _utf16LeBom(0) AndAlso buffer(1) = _utf16LeBom(1) Then Return Encoding.Utf16LeBom End If If size >= 2 AndAlso buffer(0) = _utf16BeBom(0) AndAlso buffer(1) = _utf16BeBom(1) Then Return Encoding.Utf16BeBom End If If size >= 3 AndAlso buffer(0) = _utf8Bom(0) AndAlso buffer(1) = _utf8Bom(1) AndAlso buffer(2) = _utf8Bom(2) Then Return Encoding.Utf8Bom End If Return Encoding.None End Function ''' <summary> ''' Automatically detects the Encoding type of a given byte buffer. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>The Encoding type or Encoding.None if unknown.</returns> Public Function DetectEncoding(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' First check if we have a BOM and return that if so Dim encoding = CheckBom(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' Now check for valid UTF8 encoding = CheckUtf8(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' Now try UTF16 encoding = CheckUtf16NewlineChars(buffer, size) If encoding <> Encoding.None Then Return encoding End If encoding = CheckUtf16Ascii(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' ANSI or None (binary) then If Not DoesContainNulls(buffer, size) Then Return Encoding.Ansi End If ' Found a null, return based on the preference in null_suggests_binary_ Return If(_nullSuggestsBinary, Encoding.None, Encoding.Ansi) End Function ''' <summary> ''' Checks if a buffer contains text that looks like utf16 by scanning for ''' newline chars that would be present even in non-english text. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>Encoding.none, Encoding.Utf16LeNoBom or Encoding.Utf16BeNoBom.</returns> Private Shared Function CheckUtf16NewlineChars(ByVal buffer As Byte(), ByVal size As Integer) As Encoding If size < 2 Then Return Encoding.None End If ' Reduce size by 1 so we don't need to worry about bounds checking for pairs of bytes size -= 1 Dim leControlChars = 0 Dim beControlChars = 0 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size Dim ch1 = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) Dim ch2 = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch1 = 0 Then If ch2 = &HA OrElse ch2 = &HD Then Threading.Interlocked.Increment(beControlChars) End If ElseIf ch2 = 0 Then If ch1 = &HA OrElse ch1 = &HD Then Threading.Interlocked.Increment(leControlChars) End If End If ' If we are getting both LE and BE control chars then this file is not utf16 If leControlChars > 0 AndAlso beControlChars > 0 Then Return Encoding.None End If End While If leControlChars > 0 Then Return Encoding.Utf16LeNoBom End If Return If(beControlChars > 0, Encoding.Utf16BeNoBom, Encoding.None) End Function ''' <summary> ''' Checks if a buffer contains any nulls. Used to check for binary vs text data. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> Private Shared Function DoesContainNulls(ByVal buffer As Byte(), ByVal size As Integer) As Boolean 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size If buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) = 0 Then Return True End If End While Return False End Function ''' <summary> ''' Checks if a buffer contains text that looks like utf16. This is done based ''' on the use of nulls which in ASCII/script like text can be useful to identify. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>Encoding.none, Encoding.Utf16LeNoBom or Encoding.Utf16BeNoBom.</returns> Private Function CheckUtf16Ascii(ByVal buffer As Byte(), ByVal size As Integer) As Encoding Dim numOddNulls = 0 Dim numEvenNulls = 0 ' Get even nulls 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size If buffer(pos) = 0 Then numEvenNulls += 1 End If pos += 2 End While ' Get odd nulls pos = 1 While pos < size If buffer(pos) = 0 Then numOddNulls += 1 End If pos += 2 End While Dim evenNullThreshold = numEvenNulls * 2.0 / size Dim oddNullThreshold = numOddNulls * 2.0 / size Dim expectedNullThreshold = _utf16ExpectedNullPercent / 100.0 Dim unexpectedNullThreshold = _utf16UnexpectedNullPercent / 100.0 ' Lots of odd nulls, low number of even nulls If evenNullThreshold < unexpectedNullThreshold AndAlso oddNullThreshold > expectedNullThreshold Then Return Encoding.Utf16LeNoBom End If ' Lots of even nulls, low number of odd nulls If oddNullThreshold < unexpectedNullThreshold AndAlso evenNullThreshold > expectedNullThreshold Then Return Encoding.Utf16BeNoBom End If ' Don't know Return Encoding.None End Function ''' <summary> ''' Checks if a buffer contains valid utf8. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns> ''' Encoding type of Encoding.None (invalid UTF8), Encoding.Utf8NoBom (valid utf8 multibyte strings) or ''' Encoding.ASCII (data in 0.127 range). ''' </returns> Private Function CheckUtf8(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' UTF8 Valid sequences ' 0xxxxxxx ASCII ' 110xxxxx 10xxxxxx 2-byte ' 1110xxxx 10xxxxxx 10xxxxxx 3-byte ' 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx 4-byte ' ' Width in UTF8 ' Decimal Width ' 0-127 1 byte ' 194-223 2 bytes ' 224-239 3 bytes ' 240-244 4 bytes ' ' Subsequent chars are in the range 128-191 Dim onlySawAsciiRange = True 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size Dim ch = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch = 0 AndAlso _nullSuggestsBinary Then Return Encoding.None End If Dim moreChars As Integer If ch <= 127 Then ' 1 byte moreChars = 0 ElseIf ch >= 194 AndAlso ch <= 223 Then ' 2 Byte moreChars = 1 ElseIf ch >= 224 AndAlso ch <= 239 Then ' 3 Byte moreChars = 2 ElseIf ch >= 240 AndAlso ch <= 244 Then ' 4 Byte moreChars = 3 Else Return Encoding.None ' Not utf8 End If ' Check secondary chars are in range if we are expecting any While moreChars > 0 AndAlso pos < size onlySawAsciiRange = False ' Seen non-ascii chars now ch = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch < 128 OrElse ch > 191 Then Return Encoding.None ' Not utf8 End If Threading.Interlocked.Decrement(moreChars) End While End While ' If we get to here then only valid UTF-8 sequences have been processed ' If we only saw chars in the range 0-127 then we can't assume UTF8 (the caller will need to decide) Return If(onlySawAsciiRange, Encoding.Ascii, Encoding.Utf8Nobom) End Function End Class 'End Namespace modRaccourci.vb Option Strict Off ' Pour CreateObject("WScript.Shell") Module modRaccourci Sub CreerRaccourci(ByRef sCheminRaccourci$, ByRef sCheminCible$, Optional ByRef sRepertoirDeTravail$ = "", Optional ByRef iStyleWindows% = 4, Optional ByRef sCheminIcone$ = "", Optional ByRef iIndexIcone% = 0, Optional ByRef sArguments$ = "") ' Fonction pour créer un raccourci ' Paramètres : ' ---------- ' sCheminRaccourci : Chemin du raccourci ' (ex.: C:\Documents and Settings\[MonCompteUtilisateur]\SendTo\VBWinDiff.exe.lnk) ' sCheminCible : La cible du raccourci (ex.: C:\Tmp\VBWinDiff.exe) ' Paramètres Facultatifs : ' ---------------------- ' sRepertoirDeTravail : Répertoire d'exécution, par defaut le répertoire ' contenant l'exécutable (ex.: C:\Tmp) ' iStyleWindows : Comment est affiché le programme : normal, reduit, agrandi... ' Par defaut: normal (comme pour shell en VB, ex.: 4 = normal) ' sCheminIcone : Chemin d'acces de l'icone, par defaut l'icone de ' l'exécutable cible (sinon aucun) (ex.: C:\Tmp\VBWinDiff.ico) ' iIndexIcone : L'index de l'icone dans le fichier ' ---------------------- ' Si il n'y a le .lnk à la fin on l'ajoute If Right(sCheminRaccourci, 4).ToLower <> ".lnk" Then sCheminRaccourci &= ".lnk" If sRepertoirDeTravail.Length = 0 Then _ sRepertoirDeTravail = IO.Path.GetDirectoryName(sCheminCible) ' Si un n'y a pas d'icone, on prend l'icone de l'exécutable cible ou rien If sCheminIcone.Length = 0 Then sCheminIcone = sCheminCible Dim oWSHShell As Object ' Pour Créer le raccourci Dim oShortcut As Object ' Raccourci oWSHShell = CreateObject("WScript.Shell") ' on crée un objet Shell ' Création d'un objet raccourci oShortcut = oWSHShell.CreateShortcut(sCheminRaccourci) ' Paramétrage du raccourci oShortcut.TargetPath = sCheminCible oShortcut.Arguments = sArguments oShortcut.WorkingDirectory = sRepertoirDeTravail oShortcut.WindowStyle = iStyleWindows ' ExpandEnvironmentStrings permet de traiter des variables de chemin ' telles que %windir% par exemple oShortcut.IconLocation = oWSHShell.ExpandEnvironmentStrings(sCheminIcone & ", " & iIndexIcone) oShortcut.Save() oShortcut = Nothing oWSHShell = Nothing End Sub 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 UniversalComparer.vb ' UniversalComparer.vb ' -------------------- Imports System.Reflection Public Class UniversalComparer(Of T) : Implements IComparer, IComparer(Of T) Private ReadOnly sortKeys() As SortKey Private m_bMsg As Boolean = False Private ReadOnly m_sTri$ = "" Public Sub New(sort As String) If String.IsNullOrEmpty(sort) Then sort = "" m_sTri = sort Dim type As Type = GetType(T) ' Split the list of properties. Dim props() As String = sort.Split(","c) ' Prepare the array that holds information on sort criteria. ReDim sortKeys(props.Length - 1) ' Parse the sort string. For i As Integer = 0 To props.Length - 1 ' Get the N-th member name. Dim memberName As String = props(i).Trim() If memberName.ToLower().EndsWith(" desc") Then ' Discard the DESC qualifier. sortKeys(i).Descending = True memberName = memberName.Remove(memberName.Length - 5).TrimEnd() End If ' Search for a field or a property with this name. sortKeys(i).FieldInfo = type.GetField(memberName) sortKeys(i).sMemberName = memberName If sortKeys(i).FieldInfo Is Nothing Then sortKeys(i).PropertyInfo = type.GetProperty(memberName) End If Next i End Sub Public Function Compare(x As Object, y As Object) As Integer _ Implements IComparer.Compare ' Implementation of IComparer.Compare Return Compare(CType(x, T), CType(y, T)) End Function Public Function Compare(x As T, y As T) As Integer _ Implements IComparer(Of T).Compare ' Implementation of IComparer(Of T).Compare ' Deal with simplest cases first. If x Is Nothing Then ' Two null objects are equal. If y Is Nothing Then Return 0 ' A null object is less than any non-null object. Return -1 ElseIf y Is Nothing Then ' Any non-null object is greater than a null object. Return 1 End If ' Iterate over all the sort keys. For i As Integer = 0 To sortKeys.Length - 1 Dim value1 As Object, value2 As Object Dim sortKey As SortKey = sortKeys(i) ' Read either the field or the property. If sortKey.FieldInfo IsNot Nothing Then value1 = sortKey.FieldInfo.GetValue(x) value2 = sortKey.FieldInfo.GetValue(y) Else If IsNothing(sortKey.PropertyInfo) Then If Not m_bMsg Then MsgBox( "Une clé de comparaison est introuvable : le champ indiqué n'existe pas" & vbLf & "ou bien n'est pas de portée publique !" & vbLf & GetType(T).ToString & " : " & sortKeys(i).sMemberName & " : " & m_sTri, MsgBoxStyle.Critical, "UniversalComparer:Compare") m_bMsg = True End If Return 0 End If value1 = sortKey.PropertyInfo.GetValue(x, Nothing) value2 = sortKey.PropertyInfo.GetValue(y, Nothing) End If Dim res As Integer If value1 Is Nothing AndAlso value2 Is Nothing Then ' Two null objects are equal. res = 0 ElseIf value1 Is Nothing Then ' A null object is always less than a non-null object. res = -1 ElseIf value2 Is Nothing Then ' Any object is greater than a null object. res = 1 Else ' Compare the two values, assuming that they support IComparable. res = DirectCast(value1, IComparable).CompareTo(value2) End If ' If values are different, return this value to caller. If res <> 0 Then ' Negate it if sort direction is descending. If sortKey.Descending Then res = -res Return res End If Next i ' If we get here the two objects are equal. Return 0 End Function Private Structure SortKey ' Nested type to store detail on sort keys Public FieldInfo As FieldInfo Public PropertyInfo As PropertyInfo ' True if sort is descending. Public Descending As Boolean Public sMemberName$ End Structure End Class