VBWinDiff v1.0.7.*
Table des procédures 1 - AssemblyInfo.vb 2 - modDepart.vb 2.1 - Public Sub DefinirTitreApplication 2.2 - Public Sub Depart 2.3 - Public Sub Main 3 - frmVBWinDiff.vb 3.1 - Private Function bConfirmerTailleFichier 3.2 - Private Function bEcrireFichiers 3.3 - Private Function bLireCleBRWinMerge 3.4 - Private Sub ActivationCmdPage 3.5 - Private Sub AfficherMessage 3.6 - Private Sub chkAccents_Click 3.7 - Private Sub chkCasse_Click 3.8 - Private Sub chkEspaces_Click 3.9 - Private Sub chkEspacesInsec_Click 3.10 - Private Sub chkPaginer_CheckedChanged 3.11 - Private Sub chkParag_Click 3.12 - Private Sub chkPhrases_CheckedChanged 3.13 - Private Sub chkPhrases_Click 3.14 - Private Sub chkPonctuation_CheckedChanged 3.15 - Private Sub chkPonctuation_Click 3.16 - Private Sub chkQuotes_Click 3.17 - Private Sub chkTout_Click 3.18 - Private Sub chkWinDiff_Click 3.19 - Private Sub cmdAjouterRaccourci_Click 3.20 - Private Sub cmdComp_Click 3.21 - Private Sub cmdEnleverRaccourci_Click 3.22 - Private Sub cmdPagePreced_Click 3.23 - Private Sub cmdPageSuiv_Click 3.24 - Private Sub Comparer 3.25 - Private Sub frmVBWinDiff_Load 3.26 - Private Sub frmVBWinDiff_Shown 3.27 - Private Sub GererActivationPhrasesEtParag 3.28 - Private Sub GererChkTout 3.29 - Private Sub PresicerInfoBullesWinDiff 3.30 - Private Sub VerifierRaccourci 4 - modConst.vb 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 Function sbEnleverAccents 6.9 - Public Sub EnleverEspaces 6.10 - Public Sub EnleverEspInsec 6.11 - Public Sub FusionnerMotsCoupes 6.12 - Public Sub New 6.13 - Public Sub NormaliserQuotes 7 - clsDicoTri.vb 7.1 - Public Function Trier 8 - modRaccourci.vb 8.1 - Sub CreerRaccourci 9 - modUtilFichier.vb 9.1 - Public Function asArgLigneCmd 9.2 - Public Function asLignes 9.3 - Public Function asLireFichier 9.4 - Public Function bAjouterFichier 9.5 - Public Function bAjouterFichier 9.6 - Public Function bCopierArbo 9.7 - Public Function bCopierFichier 9.8 - Public Function bCopierFichiers 9.9 - Public Function bDeplacerDossier 9.10 - Public Function bDeplacerFichiers2 9.11 - Public Function bDeplacerFichiers3 9.12 - Public Function bDossierExiste 9.13 - Public Function bEcrireFichier 9.14 - Public Function bEcrireFichier 9.15 - Public Function bFichierExiste 9.16 - Public Function bFichierExisteFiltre 9.17 - Public Function bFichierExisteFiltre2 9.18 - Public Function bReencoder 9.19 - Public Function bRenommerDossier 9.20 - Public Function bRenommerFichier 9.21 - Public Function bSupprimerDossier 9.22 - Public Function bSupprimerFichier 9.23 - Public Function bSupprimerFichiersFiltres 9.24 - Public Function bTrouverFichier 9.25 - Public Function bVerifierCreerDossier 9.26 - Public Function iNbFichiersFiltres% 9.27 - Public Function sbLireFichier 9.28 - Public Function sCheminRelatif$ 9.29 - Public Function sConvNomDos$ 9.30 - Public Function sDossierParent$ 9.31 - Public Function sEnleverSlashFinal$ 9.32 - Public Function sEnleverSlashInitial$ 9.33 - Public Function sExtraireChemin$ 9.34 - Public Function sFormaterNumerique$ 9.35 - Public Function sFormaterNumerique2$ 9.36 - Public Function sFormaterTailleKOctets$ 9.37 - Public Function sFormaterTailleOctets$ 9.38 - Public Function sLecteurDossier$ 9.39 - Public Function sLireFichier$ 9.40 - Public Function sNomDossierFinal$ 9.41 - Public Function sNomDossierParent$ 9.42 - Public Function StringReadLine$ 9.43 - Public FunctionbFichierAccessible 9.44 - Public Sub New 9.45 - Public Sub OuvrirAppliAssociee 9.46 - Public Sub OuvrirDossier 9.47 - Public Sub ProposerOuvrirFichier 10 - modUtilReg.vb 10.1 - Public Function asListeSousClesCU 10.2 - Public Function bAjouterMenuContextuel 10.3 - Public Function bAjouterTypeFichier 10.4 - Public Function bCleRegistreCRExiste 10.5 - Public Function bCleRegistreCRExiste 10.6 - Public Function bCleRegistreCUExiste 10.7 - Public Function bCleRegistreLMExiste 11 - UniversalComparer.vb 11.1 - Public Function Compare 11.2 - Public Function Compare 11.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("ORS Production")> <Assembly: AssemblyProduct("VBWinDiff")> <Assembly: AssemblyCopyright("Copyright © 2017 ORS Production")> <Assembly: AssemblyTrademark("VBWinDiff")> <Assembly: AssemblyVersion("1.0.7.*")> modDepart.vb ' Fichier modDepart.vb ' -------------------- ' VBWinDiff : Interface d'options pour le comparateur WinDiff et WinMerge ' Documentation : VBWinDiff.html ' http://patrice.dargenton.free.fr/CodesSources/VBWinDiff.html ' http://patrice.dargenton.free.fr/CodesSources/VBWinDiff.vbproj.html ' http://www.vbfrance.com/code.aspx?ID=44827 ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' Version 1.07 du 26/03/2017 Possibilité d'ignorer les sauts de ligne multiples ' Version 1.06 du 22/03/2015 ' Version 1.05 du 03/05/2014 ' Version 1.04 du 04/01/2014 ' Version 1.03 du 02/01/2011 ' Version 1.02 du 17/10/2010 ' Version 1.01 du 10/10/2010 ' 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 ' ... ' ------------------------------------ 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$ = "26/03/2017" '1.06:22/03/2015 1.05:09/05/2014 1.04:04/01/2014 1.03:02/01/2011 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()> ' Avec l'ancienne technique On Error Goto X, on pouvait désactiver la gestion ' d'erreur avec une simple constante, mais on ne pouvait pas imbriquer plusieurs ' gestions d'erreur dans une même fonction 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 frmVBWinDiff.vb ' Fichier frmVBWinDiff.vb : Interface d'options pour le comparateur WinDiff et WinMerge ' -------------------- 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(ByVal sender As Object, ByVal 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 = True Me.chkPonctuation.Checked = True Me.chkCasse.Checked = True Me.chkEspacesInsec.Checked = True Me.chkEspaces.Checked = False Me.chkQuotes.Checked = True Me.chkInfo.Checked = True Me.chkPhrases.Checked = True Me.chkPaginer.Checked = False Me.chkRatio.Checked = False Me.chkWinDiff.Checked = False Me.chkParag.Checked = True End If Me.lblChemin1.Text = sCheminFichier1 Me.lblChemin2.Text = sCheminFichier2 PresicerInfoBullesWinDiff() End Sub Private Sub AfficherMessage(ByVal 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() 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 Dim sbSrc1, sbSrc2 As StringBuilder Dim iIdxSrcOrig1%, iIdxSrcOrig2% ' 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) 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) sbSrc2 = sbLireFichier(sCheminFichier2) 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 End If If Not Me.chkAccents.Checked Then If Not bEnleverAccents(sCheminFichier1, sbSrc1, sbDest1) Then GoTo Fin If Not bEnleverAccents(sCheminFichier2, sbSrc2, sbDest2) Then GoTo Fin sbSrc1 = sbDest1 : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 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 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 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 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 sCheminDest1$ = "", sCheminDest2$ = "" If Not bEnleverPonctuation(sCheminFichier1, sbSrc1, sbDest1, _ bOptionComparerMots, bOptionComparerParag) Then GoTo Fin If Not bEnleverPonctuation(sCheminFichier2, sbSrc2, sbDest2, _ bOptionComparerMots, bOptionComparerParag) Then GoTo Fin sbSrc1 = sbDest1 : sbSrc2 = sbDest2 iNbEcritures -= 1 ' Décrémenter le nombre d'écriture restantes 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) End If If Not bEcrireFichiers(sbDest1, sbDest2, _ sCheminFichier1, sCheminFichier1Orig, _ sCheminFichier2, sCheminFichier2Orig, iIdxSrcOrig1, iIdxSrcOrig2, _ sbSrcOrig1, sbSrcOrig2) 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 End Sub Private Function bEcrireFichiers( _ ByRef sbPage1 As StringBuilder, ByRef sbPage2 As StringBuilder, _ ByVal sCheminSrc1$, ByVal sCheminSrcOrig1$, _ ByVal sCheminSrc2$, ByVal sCheminSrcOrig2$, iIdxSrcOrig1%, iIdxSrcOrig2%, _ ByVal sbSrc1Orig As StringBuilder, ByVal sbSrc2Orig As StringBuilder) 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 If iNumFichier = 2 Then sbPage = sbPage2 sCheminSrc = sCheminSrc2 sSrcOrig = sCheminSrcOrig2 iIdxSrcOrig = iIdxSrcOrig2 sbSrcOrig = sbSrc2Orig 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, 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(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdComp.Click Comparer() End Sub Private Sub chkTout_Click(ByVal sender As Object, ByVal 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 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 Then Me.chkTout.Checked = True Else Me.chkTout.Checked = False End If End Sub Private Sub chkEspacesInsec_Click(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal 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 chkPonctuation_Click(ByVal sender As Object, ByVal 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 End Sub Private Sub chkPhrases_Click(ByVal sender As Object, ByVal 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 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 chkPaginer_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPaginer.CheckedChanged ActivationCmdPage() End Sub Private Sub cmdPagePreced_Click(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal 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(ByVal sender As Object, ByVal 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 iCodeASCIIEspaceInsecable% = 160 Public Const sListeSeparateursPhrase$ = ".:?!;|¡¿" 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 ' Normalisation des quotes Public Const iCodeASCIIGuillemet% = 34 ' " 'Public Const iCodeASCIIGuillemetOuvrant% = 171 ' « 'Public Const iCodeASCIIGuillemetFermant% = 187 ' » 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 ' ´ End Module modUtil.vb ' Fichier modUtil.vb ' ------------------ Module modUtil Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub 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(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub 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(ByVal sSrc$, _ ByRef sbSrc As StringBuilder, _ ByRef sbDest As StringBuilder) As Boolean If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) If IsNothing(sbDest) Then sbDest = New StringBuilder sbDest = sbEnleverAccents(sbSrc) bEnleverAccents = True End Function Public Function sbEnleverAccents(ByVal sbChaine As StringBuilder) As StringBuilder ' Enlever les accents sbEnleverAccents = New StringBuilder If sbChaine.Length = 0 Then Exit Function Dim sChaine$ = sbChaine.ToString Const sEncodageIso8859_15$ = "iso-8859-15" Const sEncodageIso8859_8$ = "iso-8859-8" 'Const sEncodageDest$ = "windows-1252" ' Frédéric François, cœur ' iso-8859-8 -> windows-1252 : Frederic Francois, cour ' Meilleure solution ' windows-1251 -> windows-1252 : Frederic Francois, c?ur ' Ancienne solution ' iso-8859-15 -> windows-1252 : Frédéric François, c½ur ' Utile pour détecter <> ' Codepage 1241 = "windows-1251" = cyrillic ' Tableau de caractères sur 8 bit 'Dim aOctets As Byte() = GetEncoding(1251).GetBytes(sChaine) ' Chaîne de caractères sur 7 bit 'sEnleverAccents = ASCII.GetString(aOctets) ' Ok mais reste cœur qui est converti en c?ur Dim iEncodageDest% = iCodePageWindowsLatin1252 'If m_bTexteUnicode Then iEncodageDest = iEncodageUnicodeUTF8 Dim encodage1252 As Encoding = GetEncoding(iCodePageWindowsLatin1252) Dim encodage8859_8 As Encoding = GetEncoding(sEncodageIso8859_8) Dim encodageDest As Encoding = GetEncoding(iEncodageDest) Dim encodageIso8859_15 As Encoding = GetEncoding(sEncodageIso8859_15) Dim aOctets As Byte() = encodage8859_8.GetBytes(sChaine) ' "iso-8859-8" Dim sEnleverAccents$ = encodageDest.GetString(aOctets) ' 1252 ou UTF8 'If bDebug Then Debug.WriteLine("' " & sEncodageSrc & " -> " & sEncodageDest & " : " & sEnleverAccents) ' Détection des caractères propres à iso-8859-15 : ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ ' http://fr.wikipedia.org/wiki/ISO_8859-15 If String.Compare(encodageIso8859_15.GetString( _ encodage1252.GetBytes(sChaine)), sChaine) = 0 Then sbEnleverAccents.Append(sEnleverAccents) GoTo Fin End If Dim i% = 0 Dim iLen% = sChaine.Length Dim sChaineIso$ = encodageIso8859_15.GetString(encodageDest.GetBytes(sChaine)) Dim ac1, ac2, ac3 As Char() ac1 = sChaine.ToCharArray ac2 = sChaineIso.ToCharArray ac3 = sEnleverAccents.ToCharArray Dim sbDest As New StringBuilder For i = 0 To iLen - 1 If ac1(i) = ac2(i) Then sbDest.Append(ac3(i)) Else Select Case ac1(i) ' ¤ ¦ ¨ ´ ¸ ¼ ½ ¾ € Š š Ž ž Œ œ Ÿ Case "¤"c : sbDest.Append("o") Case "¦"c : sbDest.Append("|") Case "¨"c : sbDest.Append("..") Case "´"c : sbDest.Append("'") Case "¸"c : sbDest.Append(",") Case "¼"c : sbDest.Append("1/4") Case "½"c : sbDest.Append("1/2") Case "¾"c : sbDest.Append("3/4") Case "€"c : sbDest.Append("E") Case "Š"c : sbDest.Append("S") Case "š"c : sbDest.Append("s") Case "Ž"c : sbDest.Append("Z") Case "ž"c : sbDest.Append("z") Case "œ"c : sbDest.Append("oe") Case "Œ"c : sbDest.Append("OE") Case "Ÿ"c : sbDest.Append("Y") Case Else 'If bDebug Then Debug.WriteLine("?? : " & ac1(i) & ac2(i) & ac3(i)) sbDest.Append(ac1(i)) ' 22/05/2010 Laisser le car. si non trouvé End Select End If Next i 'sEnleverAccents = sbDest.ToString sbEnleverAccents = sbDest Fin: 'If bMinuscule Then sEnleverAccents = sEnleverAccents.ToLower End Function Private Sub LireInfoFichier(ByVal 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(ByVal iNumFichier%, ByVal sSrc$, ByVal sSrcOrig$, _ ByRef sbSrc As StringBuilder, _ ByRef sbSrcOrig As StringBuilder, _ ByRef sbDest As StringBuilder, _ Optional ByVal iNumPage% = 0, Optional ByVal iNbPages% = 0, _ Optional ByVal iIdxSrcOrig% = -1, _ Optional ByVal bAfficherFichier As Boolean = True, _ Optional ByVal 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 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) As Boolean Dim sbSrc1 As StringBuilder = sbLireFichier(sCheminFichier1) Dim sbSrc2 As StringBuilder = sbLireFichier(sCheminFichier2) 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(ByVal iIdxSrc%, ByVal 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(ByVal sSrc$, _ ByRef sbSrc As StringBuilder, _ ByRef sbDest As StringBuilder) If IsNothing(sbSrc) Then sbSrc = sbLireFichier(sSrc) sbDest = sbSrc.Replace(Chr(iCodeASCIIEspaceInsecable), " "c) End Sub Public Sub EnleverEspaces(ByVal 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 ' 12/12/2015 Supprimer les doubles saut de ligne si on coche Espace Dim sParagTrim$ = sParag.Trim If String.IsNullOrEmpty(sParagTrim) Then Continue For sbDest.AppendLine(sParagTrim) Next End Sub Public Function bEnleverMajuscules(ByVal 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(ByVal sSrc$, _ ByRef sbSrc As StringBuilder, _ ByRef sbDest As StringBuilder, _ ByVal bOptionComparerMots As Boolean, _ ByVal bOptionComparerParag 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)) Dim bSaut As Boolean = False For Each sParag As String In asParag If sParag.Length = 0 Then Continue For Dim asPhrases$() = sParag.Split(acSepPhrase) For Each sPhrase As String In asPhrases If sPhrase.Length = 0 Then Continue For Dim matches As MatchCollection = Regex.Matches(sPhrase, sRechMots) For i As Integer = 0 To matches.Count - 1 bSaut = False Dim sMot$ = matches(i).ToString sbDest.Append(sMot) If bOptionComparerMots Then sbDest.Append(vbCrLf) bSaut = True Else sbDest.Append(" ") End If Next If Not bSupprDblSautDeLignes OrElse Not bSaut Then sbDest.Append(vbCrLf) Next If Not bSupprDblSautDeLignes OrElse Not bSaut Then sbDest.Append(vbCrLf) Next bEnleverPonctuation = True End Function Public Sub FusionnerMotsCoupes(ByVal 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(ByVal 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) ' ´ ' 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) 'Debug.WriteLine(sbDest.ToString) End Sub End Module clsDicoTri.vb ' Classe Dictionary triable Public Class DicoTri(Of Tkey, Tvalue) : Inherits Dictionary(Of Tkey, Tvalue) Public Function Trier(Optional ByVal sOrdreTri$ = "") As Tvalue() ' Trier la Dico et renvoyer le tableau des éléments triés 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 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 'Imports System.IO ' Pour Path, File, Directory... Public Module modUtilFichier Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Const sCauseErrPossDossier$ = _ "Le dossier est peut-être protégé en écriture" & vbLf & _ "ou bien un fichier est verrouillé par une autre application" ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 ' Mettre & pour Long en DotNet1 et % pour Integer en DotNet2 Public Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern ' L'encodage UTF-8 est le meilleur compromis encombrement/capacité ' il permet l'encodage par exemple du grec, sans doubler la taille du texte '(mais le décodage est plus complexe en interne et les caractères ne s'affichent ' pas bien dans les certains logiciels utilitaires comme WinDiff, ' ni par exemple en csv pour Excel) ' http://fr.wikipedia.org/wiki/Unicode ' 65001 = Unicode UTF-8, 65000 = Unicode UTF-7 Public Const iEncodageUnicodeUTF8% = 65001 Public Const sEncodageISO_8859_1$ = "ISO-8859-1" #Region "Gestion des fichiers" 'Public Function bChoisirFichier(ByRef sCheminFichier$, sFiltre$, sExtDef$, _ ' sTitre$, Optional sInitDir$ = "", _ ' Optional bDoitExister As Boolean = True, _ ' Optional bMultiselect As Boolean = False) As Boolean ' ' Afficher une boite de dialogue pour choisir un fichier ' ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*" ' ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier ' Static bInit As Boolean = False ' Dim ofd As New OpenFileDialog ' With ofd ' If Not bInit Then ' bInit = True ' If sInitDir.Length = 0 Then ' If sCheminFichier.Length = 0 Then ' .InitialDirectory = Application.StartupPath ' Else ' .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) ' End If ' Else ' .InitialDirectory = sInitDir ' End If ' End If ' If Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier ' .CheckFileExists = bDoitExister ' 14/10/2007 ' .DefaultExt = sExtDef ' .Filter = sFiltre ' .Multiselect = bMultiselect ' .Title = sTitre ' .ShowDialog() ' If .FileName <> "" Then sCheminFichier = .FileName : Return True ' Return False ' End With 'End Function Public Function bFichierExiste(sCheminFichier$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt Dim bFichierExiste0 As Boolean = IO.File.Exists(sCheminFichier) If Not bFichierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichier introuvable") Return bFichierExiste0 End Function Public Function bFichierExisteFiltre(sCheminFiltre$, sFiltre$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim bFichierExisteFiltre0 As Boolean Dim di As New IO.DirectoryInfo(sCheminFiltre) If Not di.Exists Then bFichierExisteFiltre0 = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre0 = (iNbFichiers > 0) Fin: If Not bFichierExisteFiltre0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichiers introuvables") Return bFichierExisteFiltre0 End Function Public Function bFichierExisteFiltre2(sCheminFiltre$, _ Optional bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If sCheminFiltre.Length = 0 Then Return False 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) Return bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(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 And lTailleSrc = lTailleDest Then Return True ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Return False End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Return False 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Return False 'End If Try ' Cette fonction vient du kernel32.dll : rien à optimiser IO.File.Copy(sCheminSrc, sCheminDest) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bCopierFichier", _ "Impossible de copier le fichier source :" & vbLf & _ sCheminSrc & vbLf & "vers le fichier de destination :" & _ vbLf & sCheminDest, sCauseErrPoss) Return False End Try End Function Public Function bCopierFichiers(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 sExtDest.Length > 0 Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim aFi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = aFi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(aFi(i).Name) Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier ' Option possible : changer l'extension du fichier ' par exemple rename *.csv *.txt If bChExt Then sDest = sCheminDest & "\" & sPrefixe & _ IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Return False Next i Return True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(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) bFichierAccessible = False If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read Using fs As New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( _ "Veuillez fermer S.V.P. le fichier :" & vbLf & _ sCheminFichier & sQuestion, msgbs, m_sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _ sCheminFichier & vbLf & _ "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _ "ses attributs de protection, ou alors les droits d'accès." & _ sQuestion, msgbs, m_sTitreMsg) End If End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub ProposerOuvrirFichier(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 sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub Public Sub OuvrirAppliAssociee(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 Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) p.StartInfo.Arguments = sArguments ' Il faut indiquer le chemin de l'exe si on n'utilise pas le shell 'p.StartInfo.UseShellExecute = False If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Function sFormaterTailleOctets$(lTailleOctets&, _ Optional bDetail As Boolean = False, _ Optional bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll ' 1024 est la norme actuellement employée dans Windows, ' mais 1000 sera peut être un jour la norme ' http://fr.wikipedia.org/wiki/Octet Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1)) Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1)) Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1)) Dim sAffichage$ = "" If bDetail Then sAffichage = sFormaterNumerique(lTailleOctets) & " octets" If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko" If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo" If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go" If rNbKo >= 1 Or rNbMo >= 1 Or rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, _ bSupprimerPt0:=True) & " octets" End If End If sFormaterTailleOctets = sAffichage End Function Public Function 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 Dim nfi As Globalization.NumberFormatInfo = _ New Globalization.NumberFormatInfo ' Définition des spérateurs numériques nfi.NumberGroupSeparator = " " ' Séparateur des milliers, millions... nfi.NumberDecimalSeparator = "." ' Séparateur décimal ' 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = iNbDecimales ' 1 décimale de précision sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormaterNumerique = sFormaterNumerique.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormaterNumerique = sFormaterNumerique.Replace(sb.ToString, "") End If End If End Function Public Function sFormaterNumerique2$(rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 'sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général ' Vérifier , et . : sFormaterNumerique2 = rVal.ToString("n").Replace(",00", "").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(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) And i < 10 'TraiterMsgSysteme_DoEvents() 'Application.DoEvents() Threading.Thread.Sleep(1000) i += 1 End While If i = 10 Then If bPromptErr Then _ MsgBox("Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, MsgBoxStyle.Critical, m_sTitreMsg) Return False End If Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) Return False End Try End Function Public Function sDossierParent$(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 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 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 IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashFinal = "" : Exit Function If sChemin.EndsWith("\") Then sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1) Else sEnleverSlashFinal = sChemin End If End Function Public Function sEnleverSlashInitial$(sChemin$) ' Enlever le slash au début du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashInitial = "" : Exit Function If sChemin.StartsWith("\") Then sEnleverSlashInitial = sChemin.Substring(1) Else sEnleverSlashInitial = sChemin End If End Function Public Function bCopierArbo(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 sDest.Chars(sDest.Length - 1) <> IO.Path.DirectorySeparatorChar Then _ sDest &= IO.Path.DirectorySeparatorChar Try If Not IO.Directory.Exists(sDest) Then IO.Directory.CreateDirectory(sDest) Catch ex As Exception AfficherMsgErreur2(ex, "bCopierArbo", _ "Impossible de créer le dossier :" & vbLf & _ sDest, sCauseErrPossDossier) Return False End Try Dim aElements$() = IO.Directory.GetFileSystemEntries(sSrc) For Each sCheminElements As String In aElements Dim sNomElements$ = IO.Path.GetFileName(sCheminElements) If IO.Directory.Exists(sCheminElements) Then ' L'élement est un sous-dossier : le copier bCopierArbo(sCheminElements, sDest & sNomElements, bStatut, _ sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(sCheminElements, sDest & sNomElements, True) Catch ex As Exception If sListeErrExcep.IndexOf(" " & sNomElements & " ") = -1 Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next Return bStatut End Function Public Function sLecteurDossier$(sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function Public Sub OuvrirDossier(sCheminDossier$) ' Ouvrir un dossier via l'explorateur de fichiers Dim 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 Sub #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(sCheminFichier$, _ Optional bLectureSeule As Boolean = False) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbContenu.Append(vbCrLf) bDebut = True sbContenu.Append(sLigne) Loop While True End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Exit Function End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(sCheminFichier$, _ Optional bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbLireFichier.Append(vbCrLf) bDebut = True sbLireFichier.Append(sLigne) Loop While True End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") End Try End Function Public Function asLireFichier(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 asLireFichier = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If If bLectureSeule Then Using fs As New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encodage) ' 23/04/2013 Optimisation du mode bLectureSeule ' On doit enlever les lignes vides dues au double séparateur CrLf 'Return sr.ReadToEnd.Split(vbCrLf.ToCharArray, StringSplitOptions.RemoveEmptyEntries) ' 24/04/2013 Conserver strictement le même comportement de sr.ReadLine() ' en RAM Dim fluxChaine As New clsFluxChaine(sr.ReadToEnd) Return fluxChaine.asLignes(bVerifierCrCrLf) 'Dim lst As New Collections.Generic.List(Of String) 'While Not sr.EndOfStream ' ' A line is defined as a sequence of characters followed by ' ' a line feed ("\n"), a carriage return ("\r"), or ' ' a carriage return immediately followed by a line feed ("\r\n"). ' ' http://msdn.microsoft.com/en-us/library/system.io.streamreader.readline.aspx ' lst.Add(sr.ReadLine()) 'End While 'Return lst.ToArray End Using : End Using Else asLireFichier = IO.File.ReadAllLines(sCheminFichier, encodage) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") End Try End Function Public Function bEcrireFichier(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 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Return False End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUTF8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf bEncodageUTF16 Then ' 28/01/2013 encodage = Encoding.Unicode ' = UTF16 ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sbContenu.ToString()) sw.Close() Return True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(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 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier ' 03/02/2014 bPromptErr:=bPromptErr et non bPromptErr:=True If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPromptErr) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Return False End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sContenu) sw.Close() Return True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(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 '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 '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 Or 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 And iCode <= 90 Then bMaj = True If iCode >= 192 And iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("òóôõö", sCar) > 0 Then ' 08/05/2013 If bMaj Then sCarDest = "O" Else sCarDest = "o" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If 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 And iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 And iCode <= 90) Then bOk = True If (iCode >= 97 And iCode <= 122) Then bOk = True If (iCode >= 48 And iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function #End Region #Region "Classe Flux Chaine" ' Equivalent de mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' mais pour une chaine : optimisation des flux Public Class clsFluxChaine Private m_iNumLigne% = 0 ' Debug Private m_sChaine$ Private m_iPos% = 0 Private c13 As Char = ChrW(13) ' vbCr Private c10 As Char = ChrW(10) ' vbLf Public Sub New(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, sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, sTitreMsg) End If Else If bCleRegistreCRExiste(sCleDescriptionCmd) Then Registry.ClassesRoot.DeleteSubKeyTree(sCleDescriptionCmd) If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, sTitreMsg) Else If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "est introuvable dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, sTitreMsg) End If End If bAjouterMenuContextuel = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sDescriptionCmd) End Using 'rk.Close() Dim sCleCmd$ = sTypeFichier & "\" & sDossierShell & "\" & sCmd & "\" & sDossierCmd Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Ajouter automatiquement des guillemets " si le chemin contient au moins un espace If sCheminExe.IndexOf(" ") > -1 Then _ sCheminExe = """" & sCheminExe & """" rk.SetValue("", sCheminExe & " " & sCmdDef) End Using 'rk.Close() If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été ajouté avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", MsgBoxStyle.Information, sTitreMsg) Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel") Return False End Try End Function Public Function bCleRegistreCRExiste(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 Imports System.Collections.Generic Imports System.Reflection 'http://www.dotnet2themax.com/ShowContent.aspx?ID=05c3d0c3-ac44-4a20-92d9-16cdae040bc3 Public Class UniversalComparer(Of T) : Implements IComparer, IComparer(Of T) Private sortKeys() As SortKey Private m_bMsg As Boolean = False Private m_sTri$ = "" Public Sub New(ByVal sort As String) 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(ByVal o1 As Object, ByVal o2 As Object) As Integer _ Implements IComparer.Compare ' Implementation of IComparer.Compare Return Compare(CType(o1, T), CType(o2, T)) End Function Public Function Compare(ByVal o1 As T, ByVal o2 As T) As Integer _ Implements IComparer(Of T).Compare ' Implementation of IComparer(Of T).Compare ' Deal with simplest cases first. If o1 Is Nothing Then ' Two null objects are equal. If o2 Is Nothing Then Return 0 ' A null object is less than any non-null object. Return -1 ElseIf o2 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(o1) value2 = sortKey.FieldInfo.GetValue(o2) 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(o1, Nothing) value2 = sortKey.PropertyInfo.GetValue(o2, Nothing) End If Dim res As Integer If value1 Is Nothing And 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