VBWinBackup v1.0.4.*

Table des procédures

1 - AssemblyInfo.vb

2 - modDepart.vb
    2.1 - Public Sub Depart
    2.2 - Public Sub Main

3 - frmWinBackup.vb
    3.1 - Private Function bDezipper
    3.2 - Private Function bDossierExclu
    3.3 - Private Function bIgnorerDossier
    3.4 - Private Function bZipperArbo
    3.5 - Private Function bZipperArboDebut
    3.6 - Private Function bZipperDossierVide
    3.7 - Private Function bZipperFichier
    3.8 - Private Sub AfficherInfos
    3.9 - Private Sub AfficherMessage
    3.10 - Private Sub AjouterMenuCtxVBWB
    3.11 - Private Sub chkCopier_Click
    3.12 - Private Sub chkIgnorerErr_Click
    3.13 - Private Sub chkSansComp_Click
    3.14 - Private Sub chkTailleMax_Click
    3.15 - Private Sub chkTmp_Click
    3.16 - Private Sub chkVerifier_Click
    3.17 - Private Sub chkWindows_Click
    3.18 - Private Sub cmdAjouterMenuCtx_Click
    3.19 - Private Sub cmdAnnuler_Click
    3.20 - Private Sub cmdEnleverMenuCtx_Click
    3.21 - Private Sub cmdZip_Click
    3.22 - Private Sub EnleverMenuCtxVBWB
    3.23 - Private Sub frmWinBackup_Load
    3.24 - Private Sub frmWinBackup_Shown
    3.25 - Private Sub lbTri_Click
    3.26 - Private Sub NoterFichierGros
    3.27 - Private Sub NoterFichierOmisErr
    3.28 - Private Sub NoterFichierOmisExclu
    3.29 - Private Sub NoterFichierOmisTropGros
    3.30 - Private Sub nudGrosFichiers_DoubleClick
    3.31 - Private Sub nudTailleMaxMo_KeyUp
    3.32 - Private Sub nudTailleMaxMo_ValueChanged
    3.33 - Private Sub VerifierMenuCtx

4 - clsFichier.vb
    4.1 - Private Function Compare%
    4.2 - Private Function Compare%
    4.3 - Private Function Compare%
    4.4 - Private Function Compare%
    4.5 - Private Function CompareTo%
    4.6 - Public Property lTaille
    4.7 - Public Property sCheminFichier$
    4.8 - Public Shared Function TrierCheminFichierCroissant
    4.9 - Public Shared Function TrierCheminFichierDecroissant
    4.10 - Public Shared Function TrierTailleCroissante
    4.11 - Public Shared Function TrierTailleDecroissante
    4.12 - Public Sub New

5 - clsFichier2.vb
    5.1 - Public Sub New

6 - clsHTTri.vb
    6.1 - Public Function Trier

7 - modUtil.vb
    7.1 - Public Function bDllInstalleeGAC
    7.2 - Public Sub AfficherMsgErreur2
    7.3 - Public Sub AfficherPressePapier
    7.4 - Public Sub CopierPressePapier
    7.5 - Public Sub Sablier
    7.6 - Public Sub TraiterMsgSysteme_DoEvents

8 - modUtilFichier.vb
    8.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible
    8.2 - Public Function asArgLigneCmd
    8.3 - Public Function asLireFichier
    8.4 - Public Function bAjouterFichier
    8.5 - Public Function bAjouterFichier
    8.6 - Public Function bChoisirFichier
    8.7 - Public Function bCopierArbo
    8.8 - Public Function bCopierFichier
    8.9 - Public Function bDeplacerDossier
    8.10 - Public Function bDeplacerFichiers2
    8.11 - Public Function bDeplacerFichiers3
    8.12 - Public Function bDossierExiste
    8.13 - Public Function bEcrireFichier
    8.14 - Public Function bEcrireFichier
    8.15 - Public Function bFichierExiste
    8.16 - Public Function bFichierExisteFiltre
    8.17 - Public Function bFichierExisteFiltre2
    8.18 - Public Function bReencoder
    8.19 - Public Function bRenommerDossier
    8.20 - Public Function bRenommerFichier
    8.21 - Public Function bSupprimerDossier
    8.22 - Public Function bSupprimerFichier
    8.23 - Public Function bSupprimerFichiersFiltres
    8.24 - Public Function bVerifierCreerDossier
    8.25 - Public Function iNbFichiersFiltres%
    8.26 - Public Function sbLireFichier
    8.27 - Public Function sCheminRelatif$
    8.28 - Public Function sConvNomDos$
    8.29 - Public Function sDossierParent$
    8.30 - Public Function sEnleverSlashFinal$
    8.31 - Public Function sEnleverSlashInitial$
    8.32 - Public Function sExtraireChemin$
    8.33 - Public Function sFormaterNumerique$
    8.34 - Public Function sFormaterNumerique2$
    8.35 - Public Function sFormaterTailleOctets$
    8.36 - Public Function sLecteurDossier$
    8.37 - Public Function sLireFichier$
    8.38 - Public Function sNomDossierFinal$
    8.39 - Public Function sNomDossierParent$
    8.40 - Public Sub OuvrirAppliAssociee
    8.41 - Public Sub ProposerOuvrirFichier

9 - modUtilReg.vb
    9.1 - Public Function asListeSousClesCU
    9.2 - Public Function bAjouterMenuContextuel
    9.3 - Public Function bAjouterTypeFichier
    9.4 - Public Function bCleRegistreCRExiste
    9.5 - Public Function bCleRegistreCUExiste
    9.6 - Public Function bCleRegistreLMExiste

10 - UniversalComparer.vb
    10.1 - Public Function Compare
    10.2 - Public Function Compare
    10.3 - Public Sub New



AssemblyInfo.vb



' Fichier AssemblyInfo.vb
' -----------------------

Imports System
Imports System.Reflection

<Assembly: AssemblyTitle("VBWinBackup")> 
<Assembly: AssemblyDescription( _
    "VBWinBackup : Sauvegarde d'une arborescence de fichiers")> 
<Assembly: AssemblyCompany("ORS Production")> 
<Assembly: AssemblyProduct("VBWinBackup")> 
<Assembly: AssemblyCopyright("© 2008 ORS Production")> 
<Assembly: AssemblyTrademark("VBWinBackup")> 

<Assembly: AssemblyVersion("1.0.4.*")> 


modDepart.vb



' Fichier modDepart.vb
' --------------------

Module modDepart

Public Const sTitreMsg$ = "VBWinBackup"

#If DEBUG Then
    Public Const bDebug As Boolean = True
#Else
    Public Const bDebug As Boolean = False
#End If

Public Sub Main()

    ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE
    ' Sinon, c'est impossible de retrouver la ligne du bug,
    '  seule la fonction peut être retrouvée via la pile d'appel.
    ' C'était plus simple avec On Error Goto X, car on pouvait
    '  désactiver la gestion d'erreur avec une simple constante bTrapErr.
    If bDebug Then Depart() : Exit Sub

    ' Attention : En mode Release il faut un Try Catch ici  
    ' (s'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, "Départ " & 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

    ' Si la dll n'est pas dans le GAC
    Const sDllZip$ = "ICSharpCode.SharpZipLib"
    If Not bDllInstalleeGAC(sDllZip) Then
        ' alors vérifier si la dll est dans le dossier courant
        If Not bFichierExiste(Application.StartupPath & "\" & _
            sDllZip & ".dll", bPrompt:=True) Then Exit Sub
    End If

    Application.Run(New frmWinBackup)

End Sub

End Module


frmWinBackup.vb



' Fichier frmWinBackup.vb
' -----------------------

' VBWinBackup : Sauvegarde d'une arborescence de fichiers

' Documentation : VBWinBackup.html
' http://www.vbfrance.com/code.aspx?ID=36613
' http://patrice.dargenton.free.fr/CodesSources/VBWinBackup.html
' http://patrice.dargenton.free.fr/CodesSources/VBWinBackup.vbproj.html
' Par Patrice Dargenton : patrice.dargenton@free.fr
' http://patrice.dargenton.free.fr/index.html
' http://patrice.dargenton.free.fr/CodesSources/index.html
' http://www.vbfrance.com/listeauteur2.aspx?ID=1124
' Version 1.04 du 19/10/2008
' Version 1.03 du 16/12/2007

' Conventions de nommage des variables :
' ------------------------------------
' b pour Boolean (booléen vrai ou faux)
' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long)
' l pour Long : &
' r pour nombre Réel (Single!, Double# ou Decimal : D)
' s pour String : $
' c pour Char ou Byte
' d pour Date
' a pour Array (tableau) : ()
' o pour Object : objet instancié localement
' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé
' m_ pour variable Membre de la classe ou de la feuille (Form)
'  (mais pas pour les constantes)
' frm pour Form
' cls pour Classe
' mod pour Module
' ...
' ------------------------------------

Imports System.IO ' Pour FileStream, File, Directory...
Imports ICSharpCode.SharpZipLib.Zip

Public Class frmWinBackup

#Region "Déclarations"

' Ne jamais inclure les dossiers suivants
Private Const sListeExclusionsSys$ = _
    " \RECYCLER \Recycled" & _
    " \System Volume Information" & _
    " \Dr Watson\user.dmp " ' Laisser un espace à la fin

Private Const sDossierWin$ = "WINDOWS" ' Windows XP
'Private Const sDossierWin$ = "WINNT" ' Pour Windows 2000 mettre WINNT partout

' Ne pas inclure les dossiers suivants, sauf pour vérifier la taille des fichiers

Private Const sListeExclusionsTmp$ = _
    " \Local Settings\Temporary Internet Files" & _
    " \Local Settings\Temp" & _
    " \" & sDossierWin & "\Temp " ' " \WINDOWS\Temp " Laisser un espace à la fin 

Private Const sDossierDS$ = "Documents and Settings"
Private Const sDossierPF$ = "Program Files"

' \WINDOWS\$NtUninstall ~\$hf_mig$ ~\$NtServicePackUninstall$ ...
Private Const sDossierWinDesinst$ = "\" & sDossierWin & "\$" ' "\WINDOWS\$"

Private Const sNomZipDefaut$ = "VBWinBackup.zip"
Private Const sNomZipWinDefaut$ = "WindowsXP.zip"

Private m_lTailleMaxOctets& ' Exclure les trop gros fichiers
Private Const iConvKo% = 1024
Private Const iConvMo% = 1024 * 1024
' Finir quand même les petits fichiers en cas d'interruption
Private Const lTailleMaxOctetsSansInterrup& = 10 * iConvMo ' Soit 10 Mo
Private m_lTailleGrosFichierOctets& ' Signaler les gros fichiers

' Options
Private Const iNiveauCompressionMax% = 9 ' Niveau de compression max. et le plus lent
Private Const iNiveauCompressionMin% = 0 ' Niveau le plus faible : simple stockage
Private m_iNiveauCompression% = iNiveauCompressionMax
Private Const iCodePageFr% = 850 ' MultilingualLatinI
Private Const bRecursif As Boolean = True ' Compresser aussi les sous-dossiers
Private m_bVerifier As Boolean ' Vérifier l'accès aux fichiers sans compresser
Private m_bDossiersTmp As Boolean ' Inclure les dossiers temporaires
Private m_bAnnuler As Boolean ' Annuler l'opération en cours

' Variables courantes
Private m_zosZip As ZipOutputStream
Private m_sCheminZip$, m_sCheminDllZip$, m_sCheminExe$, m_sLecteur$
Private m_sCheminZipMaj$, m_sCheminDllZipMaj$, m_sCheminExeMaj$
Private m_sCheminFichierCourant$
Private m_iPosDebCheminRacine%, m_sCheminRacineZip$
' Bilan du contenu du zip
Private m_lTailleFichiers&, m_iNbDossiers%, m_iNbFichiers%
' Liste des fichiers particuliers
Private m_alFichiersOmisErr As ArrayList
Private m_alFichiersOmisTropGros As ArrayList
Private m_alFichiersOmisExclu As ArrayList
' Liste des gros fichiers (ou bien tous les fichiers)
Private m_alFichiersGros As ArrayList
Private m_httFichiers As HashtableTri(Of clsFichier2)

Private m_bCopier, m_bIgnorerErr As Boolean

Private Const sTriArboTaille$ = "Arbo. / Taille"
Private Const sTriTaille$ = "Taille"
Private Const sTriAlphab$ = "Alphab."
Private Const iTypeTri_ArboTaille% = 1
Private Const iTypeTri_Taille% = 2
Private Const iTypeTri_Alphab% = 3
Private m_iTypeTri%

Private m_sCheminArg$ = ""

Private Const sMenuCtx_TypeDossier$ = "Directory"
Private Const sMenuCtx_CleCmdVBWB$ = "VBWinBackup"
Private Const sMenuCtx_CleCmdVBWBDescription$ = "Bilan encombrement (VBWB)"

#End Region

#Region "Gestion des menus contextuels"

Private Sub VerifierMenuCtx()

    Dim sCleDescriptionCmd$ = sMenuCtx_TypeDossier & "\shell\" & sMenuCtx_CleCmdVBWB
    If bCleRegistreCRExiste(sCleDescriptionCmd) Then
        Me.cmdAjouterMenuCtx.Enabled = False
        Me.cmdEnleverMenuCtx.Enabled = True
    Else
        Me.cmdAjouterMenuCtx.Enabled = True
        Me.cmdEnleverMenuCtx.Enabled = False
    End If

End Sub

Private Sub cmdAjouterMenuCtx_Click(ByVal sender As Object, _
    ByVal e As EventArgs) Handles cmdAjouterMenuCtx.Click
    AjouterMenuCtxVBWB(sMenuCtx_TypeDossier)
    VerifierMenuCtx()
End Sub

Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, _
    ByVal e As EventArgs) Handles cmdEnleverMenuCtx.Click
    EnleverMenuCtxVBWB(sMenuCtx_TypeDossier)
    VerifierMenuCtx()
End Sub

Private Sub AjouterMenuCtxVBWB(ByVal sMenuCtx_TypeFichier$)

    Dim sCheminExe$ = Application.ExecutablePath
    Const bPrompt As Boolean = False
    Const sChemin$ = """%1"""
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVBWB, _
        bPrompt, , sMenuCtx_CleCmdVBWBDescription, sCheminExe, sChemin)

End Sub

Private Sub EnleverMenuCtxVBWB(ByVal sMenuCtx_TypeFichier$)

    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVBWB, _
        bEnlever:=True, bPrompt:=False)

End Sub

#End Region

#Region "Initialisation"

Private Sub frmWinBackup_Load(ByVal sender As Object, _
    ByVal e As EventArgs) Handles MyBase.Load

    Me.lbTri.Items.Add(sTriArboTaille)
    Me.lbTri.Items.Add(sTriTaille)
    Me.lbTri.Items.Add(sTriAlphab)
    Me.lbTri.SetSelected(1, True) ' TriTaille par défaut

    Dim sRepSys$ = Environment.SystemDirectory
    ' Il n'existe pas de dossier spécial pour Windows !
    'Dim sRepWin$ = Environment.GetFolderPath(Environment.SpecialFolder.System)
    Dim sRepWin$ = Path.GetDirectoryName(sRepSys)
    Dim sLecteur$ = Path.GetPathRoot(Application.StartupPath) ' Exemple : C:\
    Dim sRepWinZip$ = sLecteur & sDossierWin '"WINDOWS"
    ' VBWinBackup ne fonctionne qu'en multi-boot
    '  on ne peut pas zipper le Windows en cours de fonctionnement
    If sRepWin.ToUpper = sRepWinZip.ToUpper Then _
        Me.chkWindows.Enabled = False : GoTo Suite
    ' Seul Windows XP est prévu, changez les chemins pour
    '  les autres versions de Windows
    If Not (bDossierExiste(sLecteur & sDossierDS) And _
            bDossierExiste(sLecteur & sDossierPF) And _
            bDossierExiste(sLecteur & sDossierWin)) Then _
        Me.chkWindows.Enabled = False

Suite:
    AfficherInfos()
    VerifierMenuCtx()

End Sub

Private Sub frmWinBackup_Shown(ByVal sender As Object, ByVal e As EventArgs) _
    Handles Me.Shown

    Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command
    If sArg0.Length = 0 Then Exit Sub

    Const iCodeASCIIGuillemet% = 34 '"
    sArg0 = sArg0.Replace(Chr(iCodeASCIIGuillemet), "")
    If Not bDossierExiste(sArg0, bPrompt:=True) Then Exit Sub

    ' S'il y a un argument en ligne de commande, alors SpaceMonger
    Me.m_sCheminArg = sArg0
    Me.chkVerifier.Checked = True
    Me.nudGrosFichiers.Value = 0.2D ' 0.2 Mo = 200 Ko (ou presque :-)
    Me.lbTri.SetSelected(0, True) ' TriArboTaille
    AfficherInfos()

End Sub

Private Sub chkVerifier_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles chkVerifier.Click
    AfficherInfos()
End Sub

Private Sub chkCopier_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles chkCopier.Click
    AfficherInfos()
End Sub

Private Sub chkWindows_Click(ByVal sender As Object, _
    ByVal e As EventArgs) Handles chkWindows.Click
    AfficherInfos()
End Sub

Private Sub chkTmp_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles chkTmp.Click
    AfficherInfos()
End Sub

Private Sub chkIgnorerErr_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles chkIgnorerErr.Click
    AfficherInfos()
End Sub

Private Sub chkTailleMax_Click(ByVal sender As Object, _
    ByVal e As EventArgs) Handles chkTailleMax.Click
    AfficherInfos()
End Sub

Private Sub chkSansComp_Click(ByVal sender As Object, _
    ByVal e As EventArgs) Handles chkSansComp.Click
    AfficherInfos()
End Sub

Private Sub nudTailleMaxMo_ValueChanged(ByVal sender As Object, _
    ByVal e As EventArgs) Handles nudTailleMaxMo.ValueChanged
    AfficherInfos()
End Sub

Private Sub nudTailleMaxMo_KeyUp(ByVal sender As Object, _
    ByVal e As Windows.Forms.KeyEventArgs) Handles nudTailleMaxMo.KeyUp
    ' Prendre en compte la fin d'une saisie au clavier 
    '  (ce que ValueChanged ignore contrairement à VB6)
    AfficherInfos()
End Sub

Private Sub nudGrosFichiers_DoubleClick(ByVal sender As Object, _
    ByVal e As EventArgs) Handles nudGrosFichiers.DoubleClick
    Me.nudGrosFichiers.Value = 0 ' 0 pour noter tous les fichiers
    AfficherInfos()
End Sub

Private Sub lbTri_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles lbTri.Click

    Dim sMsg$ = ""
    Select Case Me.lbTri.Text
    Case sTriArboTaille
        sMsg = "Trier les sous-dossiers et fichiers par taille (fonctionnalité comme SpaceMonger)"
    Case sTriTaille
        sMsg = "Trier les fichiers par taille sur l'ensemble de l'arborescence"
    Case sTriAlphab
        sMsg = "Trier les fichiers par ordre alphabétique sur l'ensemble de l'arborescence"
    End Select
    AfficherMessage(sMsg)

End Sub

Private Sub AfficherInfos()

    Dim sLecteur$ = sLecteurDossier(Application.StartupPath) ' Exemple : C: 
    Dim sTypeZip$ = "l'arborescence"
    Dim sNomZip0$
    If Me.chkWindows.Checked Then
        ' Compresser Windows XP
        Me.m_sCheminRacineZip = sLecteur
        sTypeZip = "Windows XP (+ PF, DS)"
        sNomZip0 = sNomZipWinDefaut
    Else
        ' Compresser le dossier de l'application
        Me.m_sCheminRacineZip = Application.StartupPath
        sNomZip0 = sNomZipDefaut

        ' S'il y a un argument en ligne de commande, alors SpaceMonger
        If m_sCheminArg.Length > 0 Then Me.m_sCheminRacineZip = m_sCheminArg
    End If
    ' Sur la racine, il peut rester un slash final : à enlever
    Me.m_sCheminRacineZip = sEnleverSlashFinal(Me.m_sCheminRacineZip) ' 12/10/2008

    ' Noter la position du début du chemin relatif
    Me.m_iPosDebCheminRacine = Me.m_sCheminRacineZip.Length + 1
    ' Noter les fichiers à ne pas inclure dans le zip
    Me.m_sCheminZip = Me.m_sCheminRacineZip & "\" & sNomZip0
    Dim sNomDossierCourant$ = Path.GetFileName(Me.m_sCheminRacineZip)
    ' En dehors de la racine, prendre le nom du dossier courant par défaut
    If sNomDossierCourant.Length > 0 Then _
        Me.m_sCheminZip = Me.m_sCheminRacineZip & "\" & sNomDossierCourant & ".zip"
    Me.m_sCheminDllZip = Me.m_sCheminRacineZip & "\ICSharpCode.SharpZipLib.dll"
    Me.m_sCheminExe = Application.ExecutablePath
    Me.m_sLecteur = sLecteurDossier(Me.m_sCheminRacineZip)

    Dim sTypeAction$ = "Sauvegarde"
    If Me.chkVerifier.Checked Then sTypeAction = "Analyse"
    Dim sInfo$ = sTypeAction & " de " & sTypeZip & " [" & _
        Me.m_sCheminRacineZip & "]"
    Me.Text = "VBWinBackup : " & sInfo
    AfficherMessage(sInfo)

    Dim sMsg$ = "Démarrer la sauvegarde compressée de " & sTypeZip & " [" & _
        Me.m_sCheminRacineZip & "]"

    Me.m_lTailleMaxOctets = 0
    Dim rTailleMaxMo! = Me.nudTailleMaxMo.Value
    Dim sFichier$ = "les fichiers de plus de " & rTailleMaxMo & " Mo"
    If Me.chkTailleMax.Checked Then
        sMsg &= " sans inclure " & sFichier
        Me.m_lTailleMaxOctets = CLng(rTailleMaxMo * iConvMo)
    End If
    Me.ToolTip1.SetToolTip(Me.chkTailleMax, "Exclure " & sFichier)
    Me.ToolTip1.SetToolTip(Me.cmdZip, sMsg)

    Me.m_bDossiersTmp = Me.chkTmp.Checked
    Me.m_bCopier = Me.chkCopier.Checked
    Me.tbDossierCopie.Enabled = Me.m_bCopier
    Me.m_bIgnorerErr = Me.chkIgnorerErr.Checked

    m_iNiveauCompression = iNiveauCompressionMax
    If Me.chkSansComp.Checked Then m_iNiveauCompression = iNiveauCompressionMin

End Sub

Private Sub cmdZip_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles cmdZip.Click

    Me.m_bAnnuler = False
    Me.cmdAnnuler.Enabled = True
    Me.cmdZip.Enabled = False
    bZipperArboDebut()
    Me.cmdZip.Enabled = True
    Me.cmdAnnuler.Enabled = False

End Sub

Private Sub AfficherMessage(ByVal sMsg$)
    Me.sbStatusBar.Text = sMsg
    Application.DoEvents()
End Sub

Private Sub cmdAnnuler_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles cmdAnnuler.Click
    Dim sAction$ = "la compression"
    If Me.m_bVerifier Then sAction = "la vérification"
    If MsgBoxResult.Yes = MsgBox( _
        "Etes-vous sûr de vouloir interrompre " & sAction & " ?", _
        MsgBoxStyle.Question Or MsgBoxStyle.YesNo) Then _
        Me.m_bAnnuler = True
End Sub

#End Region

#Region "Gestion Zip"

Private Function bZipperArboDebut() As Boolean

    ' Démarrer la compression zip

    Me.m_alFichiersOmisErr = New ArrayList
    Me.m_alFichiersOmisTropGros = New ArrayList
    Me.m_alFichiersOmisExclu = New ArrayList
    Me.m_alFichiersGros = New ArrayList
    Me.m_httFichiers = New HashtableTri(Of clsFichier2)

    ' Si l'unité est < à 1 Mo, alors repasser en Ko
    If Me.nudGrosFichiers.Value < 1 Then
        Me.m_lTailleGrosFichierOctets = CLng(Me.nudGrosFichiers.Value * 1000 * iConvKo)
    Else
        Me.m_lTailleGrosFichierOctets = CLng(Me.nudGrosFichiers.Value * iConvMo)
    End If

    Me.m_bVerifier = Me.chkVerifier.Checked

    Me.m_sCheminZipMaj = Me.m_sCheminZip.ToUpper
    Me.m_sCheminDllZipMaj = Me.m_sCheminDllZip.ToUpper
    Me.m_sCheminExeMaj = Me.m_sCheminExe.ToUpper
    Me.m_lTailleFichiers = 0 : m_iNbDossiers = 0 : m_iNbFichiers = 0

    Select Case Me.lbTri.Text
    Case sTriArboTaille : Me.m_iTypeTri = iTypeTri_ArboTaille
    Case sTriTaille : Me.m_iTypeTri = iTypeTri_Taille
    Case sTriAlphab : Me.m_iTypeTri = iTypeTri_Alphab
    End Select

    Dim fsZip As FileStream = Nothing
    Try
        If Not Me.m_bVerifier And Not Me.m_bCopier Then
            fsZip = File.Create(Me.m_sCheminZip)
            Me.m_zosZip = New ZipOutputStream(fsZip)
            Me.m_zosZip.SetLevel(m_iNiveauCompression)

            ' Codage des fichiers en français : FAQ SharpZipLib :
            ' http://wiki.sharpdevelop.net/default.aspx/SharpZipLib.FrequentlyAskedQuestions
            ' Résultat : Ok, mais pas pour les (très rares) fichiers 
            '  avec des caractères unicodes, par exemple :
            ' C:\WINDOWS\Web\Wallpaper\Chœur d'étoiles.jpg
            ICSharpCode.SharpZipLib.Zip.ZipConstants.DefaultCodePage = _
                iCodePageFr ' 850
        End If

        Dim lTailleDossier& = 0
        If Me.chkWindows.Checked Then
            Dim lTailleDossier0& = 0
            If Not bZipperArbo(Me.m_sCheminRacineZip & "\" & _
                sDossierDS, lTailleDossier0) Then Exit Function
            lTailleDossier += lTailleDossier0
            If Not bZipperArbo(Me.m_sCheminRacineZip & "\" & _
                sDossierPF, lTailleDossier0) Then Exit Function
            lTailleDossier += lTailleDossier0
            If Not bZipperArbo(Me.m_sCheminRacineZip & "\" & _
                sDossierWin, lTailleDossier0) Then Exit Function
            lTailleDossier += lTailleDossier0
        Else
            If Not bZipperArbo(Me.m_sCheminRacineZip, lTailleDossier) Then Exit Function
        End If

        Dim sTypeOp$ = "compressés"
        If Me.m_bCopier Then sTypeOp = "copiés"
        bZipperArboDebut = True
        Me.m_iNbDossiers -= 1 ' Ne pas compter le dossier courant
        Dim sbInfo As New System.Text.StringBuilder( _
            "Rapport VBWinBackup : " & Me.m_sCheminRacineZip & vbCrLf & _
            "-------------------" & vbCrLf & _
            "Nombre de  dossiers " & sTypeOp & " : " & Me.m_iNbDossiers & vbCrLf & _
            "Nombre de  fichiers " & sTypeOp & " : " & Me.m_iNbFichiers & vbCrLf & _
            "Taille des fichiers " & sTypeOp & " : " & _
            sFormaterTailleOctets(Me.m_lTailleFichiers, bDetail:=True) & vbCrLf & _
            "------------------------------" & vbCrLf)

        Dim sCheminFichier$
        If Me.m_alFichiersOmisTropGros.Count > 0 Then _
            sbInfo.Append(vbCrLf & vbCrLf & _
                "Fichiers trop gros (> à " & sFormaterTailleOctets( _
                Me.m_lTailleMaxOctets) & ") :" & vbCrLf & _
                "------------------" & vbCrLf)
        For Each sCheminFichier In Me.m_alFichiersOmisTropGros
            sbInfo.Append(sCheminFichier & vbCrLf)
        Next
        If Me.m_alFichiersOmisErr.Count > 0 Then _
            sbInfo.Append(vbCrLf & vbCrLf & _
                "Fichiers inaccessibles :" & vbCrLf & _
                "----------------------" & vbCrLf)
        For Each sCheminFichier In Me.m_alFichiersOmisErr
            sbInfo.Append(sCheminFichier & vbCrLf)
        Next
        If Me.m_alFichiersOmisExclu.Count > 0 Then _
            sbInfo.Append(vbCrLf & vbCrLf & _
                "Dossiers & Fichiers exclus :" & vbCrLf & _
                "--------------------------" & vbCrLf)
        For Each sCheminFichier In Me.m_alFichiersOmisExclu
            sbInfo.Append(sCheminFichier & vbCrLf)
        Next

        Select Case Me.m_iTypeTri
        Case iTypeTri_Taille, iTypeTri_Alphab

            If Me.m_alFichiersGros.Count > 0 Then
                Me.AfficherMessage("Tri de la liste des fichiers...")
                If Me.lbTri.Text = sTriAlphab Then
                    sbInfo.Append(vbCrLf & vbCrLf & _
                        "Liste des fichiers :" & vbCrLf & _
                        "------------------" & vbCrLf)
                    Me.m_alFichiersGros.Sort(clsFichier.TrierCheminFichierCroissant)
                Else
                    If Me.m_lTailleGrosFichierOctets = 0 Then
                        sbInfo.Append(vbCrLf & vbCrLf & _
                            "Liste des fichiers (triés par taille)" & vbCrLf & _
                            "------------------" & vbCrLf)
                    Else
                        sbInfo.Append(vbCrLf & vbCrLf & _
                            "Gros fichiers (> à " & sFormaterTailleOctets( _
                            Me.m_lTailleGrosFichierOctets, bSupprimerPt0:=True) & ") :" & vbCrLf & _
                            "-------------" & vbCrLf)
                    End If
                    Me.m_alFichiersGros.Sort(clsFichier.TrierTailleDecroissante)
                End If
            End If
            Dim fichier As clsFichier
            For Each fichier In Me.m_alFichiersGros
                sbInfo.Append(fichier.sCheminFichier & vbCrLf)
            Next

        Case iTypeTri_ArboTaille
            ' Fonctionnalité comme SpaceMonger : tri des sous-dossiers et fichiers
            '  par taille dans le dossier
            ' Autre solution pour trier bcp + simple et universelle 
            ' (peut être un peu + lente)
            Dim fichier2 As clsFichier2
            If Me.m_httFichiers.Count > 0 Then
                If Me.m_lTailleGrosFichierOctets = 0 Then
                    sbInfo.Append(vbCrLf & vbCrLf & _
                        "Liste des dossiers et fichiers :" & vbCrLf & _
                        "------------------------------" & vbCrLf)
                Else
                    sbInfo.Append(vbCrLf & vbCrLf & _
                        "Gros dossiers et fichiers (> à " & sFormaterTailleOctets( _
                        Me.m_lTailleGrosFichierOctets, bSupprimerPt0:=True) & ") :" & vbCrLf & _
                        "-------------------------" & vbCrLf)
                End If
                For Each fichier2 In Me.m_httFichiers.Trier( _
                    "m_sCheminDossier, m_bDossier DESC, m_lTaille DESC")
                    Dim sElement$ = fichier2.m_sCheminFichier
                    If fichier2.m_bDossier Then sElement = "\" & fichier2.m_sCheminFichier
                    'sbInfo.Append(sElement & " : " & _
                    '    sFormaterTailleOctets(fichier2.m_lTaille) & vbCrLf)
                    sbInfo.Append(sFormaterTailleOctets(fichier2.m_lTaille) & _
                        " : " & sElement & vbCrLf)
                Next
            End If

        End Select

        Dim sMsg$ = "La compression est terminée !"
        If Me.m_bCopier Then sMsg = "La copie est terminée !"
        If Me.m_bVerifier Then _
            sMsg = "La vérification de l'accès aux fichiers est terminée !"

        ' Sur la racine, il peut rester un slash final : à enlever
        'Dim sChemin$ = Application.StartupPath & "\Rapport_VBWinBackup.txt"
        Dim sChemin$ = Me.m_sCheminRacineZip & "\Rapport_VBWinBackup.txt" ' 12/10/2008
        If bEcrireFichier(sChemin, sbInfo) Then
            Me.AfficherMessage(sMsg)
            ProposerOuvrirFichier(sChemin) ', sMsg)
        Else
            CopierPressePapier(sbInfo.ToString)
            AfficherPressePapier()
            sMsg &= " (cf. presse-papier pour le rapport)"
            Me.AfficherMessage(sMsg)
            MsgBox(sMsg, MsgBoxStyle.Information, sTitreMsg)
        End If

    Catch ex As Exception
        AfficherMsgErreur2(ex, "bZipperArboDebut")

    Finally
        Try
            If Not IsNothing(Me.m_zosZip) Then
                Me.m_zosZip.Finish()
                Me.m_zosZip.Close()
            End If
            ' 12/10/2008 : inclure aussi la fermeture du fs dans le try-catch
            '  car elle peut échouer aussi si le disque est plein
            If Not IsNothing(fsZip) Then fsZip.Close()
        Catch ex As Exception
            ' Interruption pendant la compression d'un fichier
            AfficherMsgErreur2(ex, "bZipperArboDebut", _
                "Le dernier fichier compressé est invalide" & _
                " à la suite d'une interruption de l'utilisateur :" & vbCrLf & _
                Me.m_sCheminFichierCourant)
        End Try
        Me.m_zosZip = Nothing

    End Try

End Function

Private Function bZipperArbo(ByVal sCheminArbo$, ByRef lTailleDossier&) As Boolean

    ' Zipper une arborescence de fichiers

    ' Si on est sur la racine et que ce n'est pas le dossier courant
    '  il faut remettre le \
    Dim sCheminArbo0$ = sCheminArbo
    If sCheminArbo0 = Me.m_sLecteur Then sCheminArbo0 &= "\"

    Dim bReessayer As Boolean
Reessayer:
    bReessayer = False

    Try ' 11/10/2008 La simple lecture des fichiers et sous-dossiers peut être refusée

        ' Lecture des fichiers et sous-dossiers
        lTailleDossier = 0
        Dim asElements$() = Directory.GetFileSystemEntries(sCheminArbo0)

        ' Sous-dossier vide : l'enregistrer dans le zip
        If asElements.Length = 0 Then
            If bDossierExclu(sCheminArbo) Then
                bZipperArbo = True : Exit Function
            End If
            Me.m_iNbDossiers += 1
            bZipperArbo = bZipperDossierVide(sCheminArbo)
            Exit Function
        End If

        Me.m_iNbDossiers += 1
        Dim bDossierDejaZippe As Boolean = False
        Dim sElement$
        For Each sElement In asElements

            Application.DoEvents() ' Pour avoir le temps d'annuler
            If Me.m_bAnnuler Then Exit Function

            If Directory.Exists(sElement) Then

                If bDossierExclu(sElement) Then GoTo ElementSuivant

                ' Stocker l'élément pour les attributs du dossier
                Dim sCheminDossier0$ = sEnleverSlashFinal(sDossierParent(sElement))
                If sCheminDossier0 <> Me.m_sCheminRacineZip Then
                    If Not bZipperDossierVide(sCheminDossier0) Then Exit Function
                    bDossierDejaZippe = True
                End If

                If Not bRecursif Then GoTo ElementSuivant

                ' L'élement est un sous-dossier : le zipper
                Dim lTailleSousDossier& = 0
                If Not bZipperArbo(sElement, lTailleSousDossier) Then Exit Function
                lTailleDossier += lTailleSousDossier

                ' Fonctionnalité comme SpaceMonger : tri des sous-dossiers 
                '  par taille dans le dossier
                If lTailleSousDossier >= Me.m_lTailleGrosFichierOctets Then
                    Dim sCheminRelatif$
                    If sCheminDossier0 = Me.m_sCheminRacineZip Then
                        sCheminRelatif = IO.Path.GetFileName(sElement) ' "\" & 
                    Else
                        sCheminRelatif = sCheminDossier0.Substring( _
                            Me.m_iPosDebCheminRacine) & "\" & IO.Path.GetFileName(sElement)
                    End If
                    Dim sCle$ = sElement
                    Me.m_httFichiers.Add(sCle, New clsFichier2( _
                        sCheminRelatif, lTailleSousDossier, bDossier:=True))
                End If

            Else

                ' Sinon zipper le fichier

                ' Mais stocker quand même l'élément pour les attributs du dossier
                If bRecursif And Not bDossierDejaZippe Then
                    Dim sCheminDossier0$ = sEnleverSlashFinal(sDossierParent(sElement))
                    If sCheminDossier0 <> Me.m_sCheminRacineZip Then
                        If Not bZipperDossierVide(sCheminDossier0) Then Exit Function
                    End If
                    bDossierDejaZippe = True
                End If

                Dim sCheminFichier$ = Path.GetFullPath(sElement)
                Dim sCheminFichierMaj$ = sCheminFichier.ToUpper
                ' Ne pas se zipper soi-même : ce n'est pas possible !
                If sCheminFichierMaj = Me.m_sCheminZipMaj Then _
                    GoTo ElementSuivant
                If sCheminFichierMaj = Me.m_sCheminDllZipMaj Then _
                    GoTo ElementSuivant
                If sCheminFichierMaj = Me.m_sCheminExeMaj Then _
                    GoTo ElementSuivant

                Dim sDossier0$ = sNomDossierParent(sElement, Me.m_sCheminRacineZip)
                If sListeExclusionsSys.LastIndexOf(sDossier0) >= 0 Then
                    NoterFichierOmisExclu(sElement)
                    GoTo ElementSuivant
                End If

                If Not Me.m_bDossiersTmp Then
                    If sListeExclusionsTmp.LastIndexOf(sDossier0) >= 0 Then
                        NoterFichierOmisExclu(sElement)
                        GoTo ElementSuivant
                    End If
                End If

                Dim sFichier$ = Path.GetFileName(sElement)
                Dim lTailleFichier& = 0
                If Not bZipperFichier(sCheminFichier, sFichier, lTailleFichier) Then
                    Me.m_bAnnuler = True
                    Exit Function
                End If
                lTailleDossier += lTailleFichier

            End If

ElementSuivant:
        Next sElement

        bZipperArbo = True

    Catch ex As Exception

        Dim sMsg$ = "Fonction : bZipperArbo"
        Dim sMsgErr$ = ""
        If ex.Message <> "" Then
            sMsgErr = ex.Message.Trim
            If Not IsNothing(ex.InnerException) Then _
                sMsgErr &= vbCrLf & ex.InnerException.Message
        End If

        If Me.m_bVerifier Or Me.m_bIgnorerErr Then
            NoterFichierOmisErr(sCheminArbo0 & " : " & sMsgErr)
            bZipperArbo = True : Exit Function
        End If

        sMsg &= vbCrLf & sMsgErr & vbCrLf & "Voulez-vous réessayer ?" & vbCrLf & _
            "(Cliquez Non pour ignorer l'erreur ou Annuler pour interrompre la compression)"
        Dim iReponse% = MsgBox(sMsg, _
            MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question, sTitreMsg)
        If iReponse = MsgBoxResult.Yes Then
            ' Si le dossier vient d'être supprimé, cela équivaut à l'ignorer
            If Not bDossierExiste(sCheminArbo0) Then _
                bZipperArbo = True : Exit Function
            bReessayer = True
        Else
            NoterFichierOmisErr(sCheminArbo0 & " : " & sMsgErr)
        End If
        ' Poursuivre en ignorant l'erreur
        If iReponse = MsgBoxResult.No Then bZipperArbo = True : Exit Function

    End Try

    If bReessayer Then GoTo Reessayer

End Function

Private Function bDossierExclu(ByVal sElement$) As Boolean

    Dim sDossierParent0$ = sNomDossierParent(sElement, Me.m_sCheminRacineZip)
    If sListeExclusionsSys.LastIndexOf(" " & sDossierParent0 & " ") >= 0 Then
        NoterFichierOmisExclu(sElement & "\")
        bDossierExclu = True : Exit Function
    End If

    If Not Me.m_bDossiersTmp Then
        If sListeExclusionsTmp.LastIndexOf( _
            " " & sDossierParent0 & " ") >= 0 Then
            NoterFichierOmisExclu(sElement & "\")
            bDossierExclu = True : Exit Function
        End If
        ' On peut aussi exclure des dossiers sur la base du seul nom du dossier
        ' (pour le moment c'est sur la base du dossier parent + dossier)
        'Dim sDossier0$ = sNomDossier(sElement)
        'If sListeExclusionsTmp.LastIndexOf( _
        '    " " & sDossier0 & " ") >= 0 Then
        '    NoterFichierOmisExclu(sElement & "\")
        '    bDossierExclu = True : Exit Function
        'End If
    End If

    ' La case à cocher Temp. sert aussi pour inclure les dossiers de désinst.
    If Not Me.m_bDossiersTmp Then
        ' "\WINDOWS\$"
        If bIgnorerDossier(sDossierParent0, sElement, _
            sDossierWinDesinst) Then bDossierExclu = True : Exit Function
    End If

End Function

Private Function bIgnorerDossier(ByVal sDossierParent$, ByVal sElement$, _
    ByVal sDossierAIgnorer$) As Boolean

    ' Vérifier si l'élément situé dans sDossierParent 
    '  correspond au dossier à ignorer

    Dim iLongDP% = sDossierParent.Length
    Dim iLongDAI% = sDossierAIgnorer.Length
    If iLongDP < iLongDAI Then Exit Function
    Dim sDossierParent1$
    If iLongDP = iLongDAI Then
        sDossierParent1 = sDossierParent
    Else
        sDossierParent1 = sDossierParent.Substring(0, iLongDAI)
    End If
    If sDossierParent1 <> sDossierAIgnorer Then Exit Function
    NoterFichierOmisExclu(sElement & "\")
    bIgnorerDossier = True

End Function

Private Sub NoterFichierOmisErr(ByVal sCheminFichier$)
    Me.m_alFichiersOmisErr.Add(sCheminFichier)
End Sub

Private Sub NoterFichierOmisTropGros(ByVal sCheminFichier$)
    Me.m_alFichiersOmisTropGros.Add(sCheminFichier)
End Sub

Private Sub NoterFichierOmisExclu(ByVal sCheminFichier$)
    Me.m_alFichiersOmisExclu.Add(sCheminFichier)
End Sub

Private Sub NoterFichierGros(ByVal sCheminFichier$, ByVal lTaille&)
    ' Noter les gros fichiers (ou bien tous les fichiers) 
    '  pour les signaler à la fin selon 2 classements possibles
    Me.m_alFichiersGros.Add(New clsFichier(sCheminFichier, lTaille))
End Sub

Private Function bZipperFichier(ByVal sCheminFichier$, ByVal sFichier$, _
    ByRef lTailleFichier&) As Boolean

    ' Zipper un fichier

    Dim bReessayer As Boolean
Reessayer:
    bReessayer = False

    Dim fsFichier As FileStream = Nothing
    lTailleFichier = 0
    Try

        Dim bDossier As Boolean = False
        'Dim sCheminDossier0$ = sCheminDossier(sCheminFichier)
        Dim sCheminDossier0$ = sEnleverSlashFinal(sDossierParent(sCheminFichier))
        Dim sCheminRelatif$
        If sCheminDossier0 = Me.m_sCheminRacineZip Then
            ' Zipper les fichiers du répertoire courant sans chemin
            sCheminRelatif = sFichier
        Else
            ' Zipper les fichiers des sous-dossiers 
            '  avec un chemin relatif au répertoire courant
            sCheminRelatif = sCheminDossier0.Substring( _
                Me.m_iPosDebCheminRacine) & "\" & sFichier
            bDossier = True
        End If

        Dim fi As New FileInfo(sCheminFichier)
        lTailleFichier = fi.Length
        If Me.m_lTailleMaxOctets > 0 AndAlso lTailleFichier > Me.m_lTailleMaxOctets Then
            NoterFichierOmisTropGros(sCheminRelatif & " : " & _
                sFormaterTailleOctets(lTailleFichier))
            bZipperFichier = True ' Ce n'est pas une erreur, continuer
            Exit Function
        End If

        Me.AfficherMessage(sCheminFichier)

        If lTailleFichier >= Me.m_lTailleGrosFichierOctets Then
            If Me.m_iTypeTri = iTypeTri_Alphab Then
                ' Noter tous les fichiers par ordre alphabétique
                Dim sPrefixe$ = ""
                If bDossier Then sPrefixe = "\"
                NoterFichierGros(sPrefixe & sCheminRelatif & " : " & _
                    sFormaterTailleOctets(lTailleFichier, bDetail:=True), _
                    lTailleFichier)
            Else
                ' Noter les gros fichiers par taille décroissante
                NoterFichierGros(sFormaterTailleOctets(lTailleFichier) & " : " & _
                    sCheminRelatif, lTailleFichier)
            End If
        End If

        ' Fonctionnalité comme SpaceMonger : tri des fichiers par taille dans le dossier
        If lTailleFichier >= Me.m_lTailleGrosFichierOctets Then
            Dim sCle$ = sCheminFichier
            Me.m_httFichiers.Add(sCle, New clsFichier2( _
                sCheminRelatif, lTailleFichier, bDossier:=False))
        End If

        ' Cette méthode équivaut à
        '  FileStream(String, FileMode.Open, FileAccess.Read, FileShare.Read)
        fsFichier = File.OpenRead(sCheminFichier)

        ' Simple vérification de l'accès au fichier
        If Me.m_bVerifier Then GoTo FinOk

        If Me.m_bCopier Then
            ' Simple copie des fichiers sans compression
            Dim sSrc$ = sCheminFichier
            Dim sDest$ = Me.tbDossierCopie.Text & "\" & sCheminRelatif
            Dim sDossierDest$ = IO.Path.GetDirectoryName(sDest)
            If Not bVerifierCreerDossier(sDossierDest) Then Exit Function
            If Not bCopierFichier(sSrc, sDest, bVerifierDate:=True) Then _
                Exit Function
            GoTo FinOk
        End If

        Dim zeElement As ZipEntry = New ZipEntry(sCheminRelatif)
        zeElement.DateTime = fi.LastWriteTime
        ' Fonction équivalente, inutile car on a déjà un fi
        'zeElement.DateTime = File.GetLastWriteTime(sCheminFichier) 

        ' L'attribut de compression NTFS n'est pas stocké à priori
        'Dim di As New DirectoryInfo(sCheminDossier0)
        ' Ne fonctionne qu'avec une version récente (0.83) de la dll SharpZipLib
        zeElement.ExternalFileAttributes = fi.Attributes ' Or di.Attributes : ne fonctionne pas ainsi
        'File.GetAttributes(sCheminFichier) ' Equivalent
        zeElement.Size = fi.Length

        'Try
            Me.m_zosZip.PutNextEntry(zeElement)
        'Catch ex As Exception
            ' Version DotNet1 de SharpZipLib :
            ' Si le total des fichiers > 2.1 Go (= Int32.MaxValue) on obtient l'erreur
            '  "Offset : Specified argument was out of the range of valid values"
            '  car ZipEntry.Offset est un Int32
        'End Try

        ' Lecture et zip du fichier par bloc de 4096 octets
        Const iTailleBuffer% = 4096
        Dim abContenu(iTailleBuffer - 1) As Byte
        Dim lNbOctetsTot& = 0
        Me.m_sCheminFichierCourant = sCheminFichier
        Do
            Application.DoEvents() ' Pour avoir le temps d'annuler 
            ' Mais finir le fichier en cours quand même pour éviter une erreur, 
            '  sauf pour les gros fichiers (> 10 Mo)
            If Me.m_bAnnuler AndAlso _
                lTailleFichier > lTailleMaxOctetsSansInterrup Then
                Exit Do
            End If
            Dim iNbOctets% = fsFichier.Read(abContenu, 0, iTailleBuffer)
            If iNbOctets < 1 Then Exit Do
            Me.m_zosZip.Write(abContenu, 0, iNbOctets)
            lNbOctetsTot += iNbOctets
        Loop
        If lNbOctetsTot <> lTailleFichier Then
            If Not Me.m_bAnnuler Then _
                MsgBox("Echec de la compression : la taille ne correspond pas", _
                    MsgBoxStyle.Critical, sTitreMsg)
            Exit Function
        End If

FinOk:
        Me.m_lTailleFichiers += lTailleFichier
        Me.m_iNbFichiers += 1

        bZipperFichier = True

    Catch ex As Exception

        Dim sMsg$ = "Fonction : bZipperFichier"
        Dim sMsgErr$ = ""
        If ex.Message <> "" Then
            sMsgErr = ex.Message.Trim
            If Not IsNothing(ex.InnerException) Then _
                sMsgErr &= vbCrLf & ex.InnerException.Message
        End If

        If Me.m_bVerifier Or Me.m_bIgnorerErr Then
            NoterFichierOmisErr(sCheminFichier & " : " & sMsgErr)
            bZipperFichier = True : Exit Function
        End If

        sMsg &= vbCrLf & sMsgErr & vbCrLf & "Voulez-vous réessayer ?" & vbCrLf & _
            "(Cliquez Non pour ignorer l'erreur ou Annuler pour interrompre la compression)"
        Dim iReponse% = MsgBox(sMsg, _
            MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Question, sTitreMsg)
        If iReponse = MsgBoxResult.Yes Then
            ' Si le fichier vient d'être supprimé, cela équivaut à l'ignorer
            If Not bFichierExiste(sCheminFichier) Then _
                bZipperFichier = True : Exit Function
            bReessayer = True
        Else
            NoterFichierOmisErr(sCheminFichier & " : " & sMsgErr)
        End If
        ' Poursuivre en ignorant l'erreur
        If iReponse = MsgBoxResult.No Then bZipperFichier = True : Exit Function

    Finally
        If Not IsNothing(fsFichier) Then fsFichier.Close()
    End Try

    If bReessayer Then GoTo Reessayer

End Function

Private Function bZipperDossierVide(ByVal sCheminDossierVide$) As Boolean

    ' Stocker un dossier vide dans le zip (avec un chemin relatif 
    '  au répertoire courant) pour respecter l'arborescence 
    '  et aussi pour conserver les attributs du dossier

    ' Simple vérification de l'accès aux fichiers : on ne fait rien ici
    If Me.m_bVerifier Then GoTo FinOk

    ' Simple copie des fichiers sans compression
    If Me.m_bCopier Then GoTo FinOk

    Dim sCheminRelatif$ = ""
    If sCheminDossierVide.Length > Me.m_iPosDebCheminRacine Then ' 12/10/2008
        sCheminRelatif = sCheminDossierVide.Substring(Me.m_iPosDebCheminRacine)
    Else
        sCheminRelatif = sCheminDossierVide
    End If

    ' Pour stocker un dossier dans le zip, il suffit de mettre une
    '  entrée avec \ à la fin
    sCheminRelatif &= "\"
    Dim zeElement As ZipEntry = New ZipEntry(sCheminRelatif)
    Dim di As New DirectoryInfo(sCheminDossierVide)
    zeElement.DateTime = di.LastWriteTime
    zeElement.ExternalFileAttributes = di.Attributes
    Me.m_zosZip.PutNextEntry(zeElement)

FinOk:
    bZipperDossierVide = True

End Function

Private Function bDezipper(ByVal sCheminFichierZip$, ByVal sCheminDossierExtract$, _
    Optional ByVal sFichierADezip$ = "") As Boolean

    ' Cette fonction marche mais elle n'a pas été testée avec de très gros zip
    ' La restauration des attributs n'a pas été faite
    ' Exemple : bDezipper("C:\Tmp\MonZip.zip", "C:\Tmp\TestExtraction")
    ' Exemple : bDezipper("C:\Tmp\MonZip.zip", "C:\Tmp\TestExtraction", _
    '               "Dossier n°1/Fichier à extraire.txt")

    Dim iNbDezip% = 0
    Dim bUnSeulFichierADezip As Boolean
    If sFichierADezip.Length > 0 Then bUnSeulFichierADezip = True

    Dim fsZip As FileStream = Nothing
    Dim zis As ZipInputStream = Nothing
    Dim fsFichier As FileStream = Nothing

    Try

        ' Cette méthode équivaut à
        '  FileStream(String, FileMode.Open, FileAccess.Read, FileShare.Read)
        fsZip = File.OpenRead(sCheminFichierZip)
        zis = New ZipInputStream(fsZip)
        ' Codage des fichiers en français 
        ICSharpCode.SharpZipLib.Zip.ZipConstants.DefaultCodePage = iCodePageFr                 ' 850

        Dim zeElement As ZipEntry = zis.GetNextEntry
        Directory.CreateDirectory(sCheminDossierExtract)

        While Not zeElement Is Nothing

            If Me.m_bAnnuler Then Exit Function

            If (zeElement.IsDirectory) Then

                ' Si on cherche à dézipper un seul fichier,
                '  ne pas recréer les dossiers
                If bUnSeulFichierADezip Then GoTo ElementSuivant
                iNbDezip += 1
                Directory.CreateDirectory( _
                    sCheminDossierExtract & "\" & zeElement.Name)

            Else

                ' Chemin relatif du fichier compressé
                Dim sFichierComp$ = zeElement.Name
                If bUnSeulFichierADezip Then
                    If sFichierComp <> sFichierADezip Then GoTo ElementSuivant
                    ' Enlever le répertoire
                    sFichierComp = Path.GetFileName(sFichierComp)
                Else
                    Dim sCheminDossier$ = sCheminDossierExtract & "\" & _
                        Path.GetDirectoryName(zeElement.Name)
                    If Not Directory.Exists(sCheminDossier) Then _
                        Directory.CreateDirectory(sCheminDossier)
                End If

                ' Cette méthode équivaut à FileStream(String, FileMode.OpenOrCreate,
                '  FileAccess.Write, FileShare.None)
                Dim sCheminFichierComp$ = _
                    sCheminDossierExtract & "\" & sFichierComp
                fsFichier = File.OpenWrite(sCheminFichierComp)
                Dim lTailleFichier& = zeElement.Size
                Dim lNbOctetsTot& = 0
                Const iTailleBuffer% = 4096
                Dim abContenu(iTailleBuffer) As Byte
                Do
                    Application.DoEvents() ' Pour avoir le temps d'annuler 
                    ' Mais finir le fichier en cours quand même pour éviter une erreur, 
                    '  sauf pour les gros fichiers (> 10 Mo)
                    If Me.m_bAnnuler AndAlso _
                        lTailleFichier > lTailleMaxOctetsSansInterrup Then
                        Exit Do
                    End If
                    Dim iNbOctets% = zis.Read(abContenu, 0, iTailleBuffer)
                    If iNbOctets < 1 Then Exit Do
                    fsFichier.Write(abContenu, 0, iNbOctets)
                    lNbOctetsTot += iNbOctets
                Loop
                fsFichier.Close()
                If lNbOctetsTot <> lTailleFichier Then
                    If Not Me.m_bAnnuler Then _
                        MsgBox("Echec de la décompression : la taille ne correspond pas", _
                            MsgBoxStyle.Critical, sTitreMsg)
                    Exit Function
                End If
                iNbDezip += 1

                ' Restaurer la date du fichier décompressé
                Dim fi As New FileInfo(sCheminFichierComp)
                fi.LastWriteTime = zeElement.DateTime
                fi = Nothing

                If bUnSeulFichierADezip Then Exit While

            End If

ElementSuivant:
            zeElement = zis.GetNextEntry

        End While

        MsgBox("La décompression a été effectuée avec succès !", _
            MsgBoxStyle.Information, sTitreMsg)
        bDezipper = True

    Catch ex As Exception
        AfficherMsgErreur2(ex, "bDezipper", _
            "Erreur lors de la décompression du fichier zip")
    Finally
        If Not (fsFichier Is Nothing) Then fsFichier.Close()
        If Not (zis Is Nothing) Then zis.Close()
        If Not (fsZip Is Nothing) Then fsZip.Close()
    End Try

End Function

#End Region

End Class


clsFichier.vb



' Fichier clsFichier.vb
' ---------------------

' Classe pour trier des fichiers par leur taille
' d'après : http://support.microsoft.com/default.aspx?scid=kb;fr;321292

Imports System.Collections

Public Class clsFichier : Implements IComparable

#Region "Classes imbriquées pour le tri secondaire"

Private Class clsTriTailleCroissante : Implements IComparer
    Private Function Compare%(ByVal oF1 As Object, ByVal oF2 As Object) _
        Implements IComparer.Compare
        Dim f1 As clsFichier = CType(oF1, clsFichier)
        Dim f2 As clsFichier = CType(oF2, clsFichier)
        If (f1.lTaille > f2.lTaille) Then
            Return 1
        ElseIf (f1.lTaille < f2.lTaille) Then
            Return -1
        Else
            Return 0
        End If
    End Function
End Class

Private Class clsTriTailleDecroissante : Implements IComparer
    Private Function Compare%(ByVal oF1 As Object, ByVal oF2 As Object) _
        Implements IComparer.Compare
        Dim f1 As clsFichier = CType(oF1, clsFichier)
        Dim f2 As clsFichier = CType(oF2, clsFichier)
        If (f1.lTaille < f2.lTaille) Then
            Return 1
        ElseIf (f1.lTaille > f2.lTaille) Then
            Return -1
        Else
            Return 0
        End If
    End Function
End Class

Private Class clsTriFichierCroissant : Implements IComparer
    Private Function Compare%(ByVal oF1 As Object, ByVal oF2 As Object) _
        Implements IComparer.Compare
        Return String.Compare(CType(oF1, clsFichier).sCheminFichier, _
                              CType(oF2, clsFichier).sCheminFichier)
    End Function
End Class

Private Class clsTriFichierDecroissant : Implements IComparer
    Private Function Compare%(ByVal oF1 As Object, ByVal oF2 As Object) _
        Implements IComparer.Compare
        Return String.Compare(CType(oF2, clsFichier).sCheminFichier, _
                              CType(oF1, clsFichier).sCheminFichier)
    End Function
End Class

#End Region

Private m_lTaille&, m_sCheminFichier$, m_sCheminDossier$

Public Sub New(ByVal sCheminFichier$, ByVal lTaille&)
    Me.m_sCheminFichier = sCheminFichier ' Chemin relatif, avec parfois la taille
    Me.m_lTaille = lTaille
End Sub

Public Property lTaille&()
    Get
        Return Me.m_lTaille
    End Get
    Set(ByVal lValue&)
        Me.m_lTaille = lValue
    End Set
End Property

Public Property sCheminFichier$()
    Get
        Return Me.m_sCheminFichier
    End Get
    Set(ByVal sCheminFichier$)
        Me.m_sCheminFichier = sCheminFichier
    End Set
End Property

Private Function CompareTo%(ByVal obj As Object) Implements IComparable.CompareTo
    Return String.Compare(Me.m_sCheminFichier, _
        CType(obj, clsFichier).sCheminFichier)
End Function

Public Shared Function TrierTailleCroissante() As IComparer
    Return CType(New clsTriTailleCroissante, IComparer)
End Function

Public Shared Function TrierTailleDecroissante() As IComparer
    Return CType(New clsTriTailleDecroissante, IComparer)
End Function

Public Shared Function TrierCheminFichierCroissant() As IComparer
    Return CType(New clsTriFichierCroissant, IComparer)
End Function

Public Shared Function TrierCheminFichierDecroissant() As IComparer
    Return CType(New clsTriFichierDecroissant, IComparer)
End Function

End Class


clsFichier2.vb



' Fichier clsFichier2.vb
' ----------------------

' Classe pour trier des fichiers de différentes façons
'  via le comparateur universel (UniversalComparer.vb)

Public Class clsFichier2

' Mettre en Public pour pouvoir utiliser le comparateur universel
' (ou sinon trier via les propriétés : + lent)
'Private m_lTaille&, m_sCheminFichier$, m_sCheminDossier$
Public m_lTaille&, m_sCheminFichier$, m_sCheminDossier$, m_sFichier$
Public m_bDossier As Boolean

Public Sub New(ByVal sCheminFichier$, ByVal lTaille&, _
    ByVal bDossier As Boolean)
    Me.m_sFichier = IO.Path.GetFileName(sCheminFichier)
    Me.m_sCheminFichier = sCheminFichier ' Chemin relatif
    Me.m_sCheminDossier = sDossierParent(sCheminFichier)
    Me.m_bDossier = bDossier
    Me.m_lTaille = lTaille
End Sub

End Class


clsHTTri.vb



' Classe hashtable triable

Public Class HashtableTri(Of T) : Inherits Hashtable

'    Implements ICloneable
'Public Overrides Function Clone() As Object Implements ICloneable.Clone
'    Return DirectCast(MemberwiseClone(), clsXXX)
'End Function

Public Function Trier(Optional ByVal sOrdreTri$ = "") As T()

    ' Trier la hashtable et renvoyer le tableau des éléments triés

    Dim iNbLignes% = Me.Count
    Dim aArt(iNbLignes - 1) As T
    Dim iNumLigne% = 0
    Dim de As IDictionaryEnumerator = Me.GetEnumerator
    While de.MoveNext
        Dim oT As T = DirectCast(Me(de.Key), T)
        aArt(iNumLigne) = oT
        iNumLigne += 1
    End While
    ' Si pas de tri demandé, retourner simplement le tableau tel quel
    If sOrdreTri.Length = 0 Then GoTo Fin
    ' Tri des éléments
    Dim comp As New UniversalComparer(Of T)(sOrdreTri)
    Array.Sort(Of T)(aArt, comp)
Fin:
    Trier = aArt

End Function

End Class


modUtil.vb



' Fichier modUtil.vb
' ------------------

Module modUtil

Public Sub AfficherMsgErreur2(ByVal 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
        ' Permet d'avoir le type de l'exception, par ex.: IndexOutOfRangeException
        sMsg &= vbCrLf & Ex.GetType.ToString
        If Not IsNothing(Ex.InnerException) Then _
            sMsg &= vbCrLf & Ex.InnerException.Message
        ' Permet d'avoir le n° de ligne où s'est produit l'erreur
        ' (en mode debug dans l'IDE, et aussi en mode release dans l'IDE à condition de générer
        '  les infos de débogage au moins pdb-only, sinon seulement le nom de la fonction)
        '  Exemple :
        '   à System.Data.ProviderBase.FieldNameLookup.GetOrdinal(String fieldName)
        '   à System.Data.OleDb.OleDbDataReader.GetOrdinal(String name)
        '   à System.Data.OleDb.OleDbDataReader.get_Item(String name)
        '   à maFct() dans C:\Tmp\module.vb:ligne 279
        If Not IsNothing(Ex.StackTrace) Then _
            sMsg &= vbCrLf & "[" & Ex.StackTrace & "]"
    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 AfficherPressePapier()

    ' Afficher le contenu du presse-papier dans le bloc-notes
    '  (il y a parfois des ratés ! créer un fichier sur disque au besoin)

    Shell("notepad.exe", AppWinStyle.NormalFocus)
    Application.DoEvents()
    Threading.Thread.Sleep(1000)
    SendKeys.Send("^V") ' Ctrl V = Coller

End Sub

Public Function bDllInstalleeGAC(ByVal sDllSansExtension$) As Boolean

    ' Renvoyer vrai si une Dll (assembly) est installée dans le GAC
    ' (auquel cas il n'est pas besoin de vérifier la présence de la dll 
    '  dans le dossier de l'application)
    ' Note : La fonction renvoie vrai aussi si la dll est présente 
    '  dans le dossier de l'application
    ' Ex.: If bDllInstalleeGAC("ICSharpCode.SharpZipLib") Then...
    Try
        ' La méthode est maintenant dépréciée en DN2, mais pourtant Load ne
        '  fonctionne pas ici : Load ne permet pas de savoir si la dll est 
        '  dans le GAC, alors que cela fonctionne tjrs avec LoadWithPartialName
        Dim asm As Reflection.Assembly = _
            Reflection.Assembly.LoadWithPartialName(sDllSansExtension)
            'Reflection.Assembly.Load(sDllSansExtension)
        If IsNothing(asm) Then Exit Function
        bDllInstalleeGAC = True
    Catch ex As Exception
    End Try

End Function

Public Sub TraiterMsgSysteme_DoEvents()

    Try
        Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire
    Catch
    End Try

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...

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"

#Region "Gestion des fichiers"

Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _
    ByVal sTitre$, Optional ByVal sInitDir$ = "", _
    Optional ByVal bDoitExister As Boolean = True) 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 = False
        .Title = sTitre
        .ShowDialog()
        If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName
    End With

End Function

Public Function bFichierExiste(ByVal sCheminFichier$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourne True si un fichier correspondant est trouvé
    ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt
    bFichierExiste = IO.File.Exists(sCheminFichier)

    If Not bFichierExiste And bPrompt Then _
        MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _
            MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable")

End Function

Public Function bFichierExisteFiltre(ByVal sCheminFiltre$, ByVal sFiltre$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourne True si au moins un fichier correspondant au filtre est trouvé
    '  dans le répertoire indiqué, ex.: C:\Tmp avec *.txt
    Dim di As New IO.DirectoryInfo(sCheminFiltre)
    Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés
    Dim iNbFichiers% = afi.GetLength(0)
    bFichierExisteFiltre = (iNbFichiers > 0)

    If Not bFichierExisteFiltre And bPrompt Then _
        MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _
            MsgBoxStyle.Critical, sTitreMsg & " - Fichiers introuvables")

End Function

Public Function bFichierExisteFiltre2(ByVal sCheminFiltre$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourner True si un fichier correspondant au filtre est trouvé
    '  Exemple de filtre : C:\Tmp\*.txt

    If sCheminFiltre.Length = 0 Then Exit Function
    'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0)
    Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre)
    Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre)
    bFichierExisteFiltre2 = bFichierExisteFiltre(sDossier, sFiltre, bPrompt)

End Function

Public Function iNbFichiersFiltres%(ByVal sCheminDossier$, ByVal sFiltre$)

    ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt
    Dim di As New IO.DirectoryInfo(sCheminDossier)
    If Not di.Exists Then Exit Function
    Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo
    iNbFichiersFiltres = fi.GetLength(0)

End Function

Public Function bCopierFichier(ByVal sCheminSrc$, ByVal sCheminDest$, _
    Optional ByVal bPromptErr As Boolean = True, _
    Optional ByVal bVerifierDate As Boolean = False) As Boolean

    If bVerifierDate Then
        If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Exit Function
        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 _
                bCopierFichier = True : Exit Function
            ' Sinon supprimer le fichier de destination
            If Not bSupprimerFichier(sCheminDest) Then Exit Function
        End If
    End If

    If Not bFichierExiste(sCheminSrc, bPromptErr) Then Exit Function
    'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier
        If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Exit Function
    'End If
    Try
        IO.File.Copy(sCheminSrc, sCheminDest)
        bCopierFichier = 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)
    End Try

End Function

Public Function bSupprimerFichier(ByVal sCheminFichier$, _
    Optional ByVal bPromptErr As Boolean = False) As Boolean

    ' Vérifier si le fichier existe
    If Not bFichierExiste(sCheminFichier) Then _
        bSupprimerFichier = True : Exit Function

    If Not bFichierAccessible(sCheminFichier, _
        bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then _
        Exit Function

    ' Supprimer le fichier
    Try
        IO.File.Delete(sCheminFichier)
        bSupprimerFichier = True
    Catch ex As Exception
        If bPromptErr Then _
            MsgBox("Impossible de supprimer le fichier :" & vbLf & _
                sCheminFichier & vbLf & _
                sCauseErrPoss, MsgBoxStyle.Critical, sTitreMsg)
    End Try

End Function

Public Function bSupprimerFichiersFiltres(ByVal sCheminDossier$, ByVal sFiltre$, _
    Optional ByVal bPromptErr As Boolean = False) As Boolean

    ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt
    ' Si le dossier n'existe pas, on considère que c'est un succès
    If Not bDossierExiste(sCheminDossier) Then bSupprimerFichiersFiltres = True : Exit Function
    Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre)
    For Each sFichier As String In asFichier
        If Not bSupprimerFichier(sFichier, bPromptErr) Then Exit Function
    Next sFichier
    bSupprimerFichiersFiltres = True

End Function

Public Function bRenommerFichier(ByVal sSrc$, ByVal sDest$, _
    Optional ByVal bConserverDest As Boolean = False) As Boolean

    ' Renommer ou déplacer un et un seul fichier

    If Not bFichierExiste(sSrc, bPrompt:=True) Then Exit Function

    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) Then Exit Function
            bRenommerFichier = True
            Exit Function
        End If
    Else
        If Not bSupprimerFichier(sDest) Then Exit Function
    End If

    Try
        IO.File.Move(sSrc, sDest)
        bRenommerFichier = 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)
    End Try

End Function

Public Function bDeplacerFichiers2(ByVal sSrc$, ByVal sDest$) As Boolean

    ' Renommer ou déplacer une arborescence de fichiers
    ' Attention : cette fonction nécessite la suppression du dossier src 
    ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3

    ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis
    ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\
    ' Cette fonction est déjà dans : modUtilFichierLT.vb

    Dim bStatut As Boolean, sListeErr$ = ""
    If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Exit Function
    Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc)
    If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Exit Function
    bDeplacerFichiers2 = True

End Function

Public Function bDeplacerFichiers3(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _
    Optional ByVal bConserverDest As Boolean = True, _
    Optional ByVal sExtDest$ = "", Optional ByVal sPrefixe$ = "") As Boolean

    ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination
    '  en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination
    '  (option par défaut pour conserver la date)

    If Not bVerifierCreerDossier(sCheminDest) Then Exit Function

    Dim bChExt As Boolean = False
    If sExtDest.Length > 0 Then bChExt = True

    Dim di As New IO.DirectoryInfo(sCheminSrc)
    Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives
    Dim iNbFichiers% = fi.GetLength(0)
    Dim i%
    For i = 0 To iNbFichiers - 1
        Dim sFichier$ = IO.Path.GetFileName(fi(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 Exit Function
    Next i

    bDeplacerFichiers3 = True

End Function

' Attribut pour éviter que l'IDE s'interrompt en cas d'exception
<System.Diagnostics.DebuggerStepThrough()> _
Public Function bFichierAccessible(ByVal sCheminFichier$, _
    Optional ByVal bPrompt As Boolean = False, _
    Optional ByVal bPromptFermer As Boolean = False, _
    Optional ByVal bInexistOk As Boolean = False, _
    Optional ByVal bPromptRetenter As Boolean = False, _
    Optional ByVal bLectureSeule As Boolean = False) As Boolean

    ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple)

    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, même une simple ouverture n'est pas permise
        Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open)
            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)
                reponse = MsgBox( _
                    "Veuillez fermer S.V.P. le fichier :" & vbLf & _
                    sCheminFichier & sQuestion, msgbs, 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, sTitreMsg)
            End If
        End If
    End Try

    If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter

End Function

Public Sub ProposerOuvrirFichier(ByVal sCheminFichier$, _
    Optional ByVal sInfo$ = "")

    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub
    Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length
    Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier)
    Dim sMsg$ = _
        "Le fichier " & IO.Path.GetFileName(sCheminFichier) & _
        " a été créé avec succès :" & vbLf & _
        sCheminFichier
    If sInfo.Length > 0 Then sMsg &= vbLf & sInfo
    sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")"
    If MsgBoxResult.Cancel = MsgBox(sMsg, _
        MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub
    OuvrirAppliAssociee(sCheminFichier)

End Sub

Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _
    Optional ByVal bMax As Boolean = False, _
    Optional ByVal bVerifierFichier As Boolean = True)
    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)
    If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized
    p.Start()
End Sub

Public Function sFormaterTailleOctets$(ByVal lTailleOctets&, _
    Optional ByVal bDetail As Boolean = False, _
    Optional ByVal bSupprimerPt0 As Boolean = False)

    ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère
    ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll

    ' 1024 est la norme actuellement employée dans Windows, 
    '  mais 1000 sera peut être un jour la norme
    ' http://fr.wikipedia.org/wiki/Octet

    Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1))
    Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1))
    Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1))
    Dim sAffichage$ = ""

    If bDetail Then
        sAffichage = sFormaterNumerique(lTailleOctets) & " octets"
        If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko"
        If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo"
        If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go"
        If rNbKo >= 1 Or rNbMo >= 1 Or rNbGo >= 1 Then sAffichage &= ")"
    Else
        If rNbGo >= 1 Then
            sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0) & " Go"
        ElseIf rNbMo >= 1 Then
            sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo"
        ElseIf rNbKo >= 1 Then
            sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko"
        Else
            sAffichage = sFormaterNumerique(lTailleOctets, _
                bSupprimerPt0:=True) & " octets"
        End If
    End If

    sFormaterTailleOctets = sAffichage

End Function

Public Function sFormaterNumerique$(ByVal rVal!, _
    Optional ByVal bSupprimerPt0 As Boolean = True)

    ' 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 = 1 ' 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 _
        sFormaterNumerique = sFormaterNumerique.Replace(".0", "")

End Function

Public Function sFormaterNumerique2$(ByVal rVal!)

    ' Formater un numérique selon le format choisi dans le panneau de config.
    ' Le format numérique standard est correct (séparation des milliers et plus), 
    '  il suffit juste d'enlever la décimale inutile si 0
    sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général

End Function

#End Region

#Region "Gestion des dossiers"

Public Function bVerifierCreerDossier(ByVal sCheminDossier$) As Boolean

    ' Vérifier si le dossier existe, et le créer sinon

    Dim di As New IO.DirectoryInfo(sCheminDossier)
    If di.Exists Then bVerifierCreerDossier = True : Exit Function

    di.Create()
    di = New IO.DirectoryInfo(sCheminDossier)
    If di.Exists Then bVerifierCreerDossier = True : Exit Function

    MsgBox("Impossible de créer le dossier :" & vbCrLf & sCheminDossier, _
        MsgBoxStyle.Critical, sTitreMsg)

End Function

Public Function bDossierExiste(ByVal sCheminDossier$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé
    'Dim di As New IO.DirectoryInfo(sCheminDossier)
    'bDossierExiste = di.Exists()
    bDossierExiste = IO.Directory.Exists(sCheminDossier)

    If Not bDossierExiste And bPrompt Then _
        MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _
            MsgBoxStyle.Critical, sTitreMsg & " - Dossier introuvable")

End Function

Public Function bRenommerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$) As Boolean

    ' Renommer ou déplacer un et un seul dossier
    ' Idem bDeplacerDossier

    If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function
    If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Exit Function

    Try
        IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest)
        bRenommerDossier = 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)
    End Try

End Function

Public Function bDeplacerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$, _
    Optional ByVal bPromptErr As Boolean = True) As Boolean

    ' Renommer ou déplacer un et un seul dossier
    ' Idem bRenommerDossier
    ' Roir aussi My.Computer.MoveDirectory en DotNet2

    If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function
    If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Exit Function

    Try
        'Dim di As New IO.DirectoryInfo(sCheminDossierSrc)
        'di.MoveTo(sCheminDossierDest)
        IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest)
        bDeplacerDossier = 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)
    End Try

End Function

Public Function bSupprimerDossier(ByVal sCheminDossier$, _
    Optional ByVal bPromptErr As Boolean = False) As Boolean

    ' Vérifier si le dossier existe
    If Not bDossierExiste(sCheminDossier) Then _
        bSupprimerDossier = True : Exit Function

    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()
            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, sTitreMsg)
            Exit Function
        End If
        bSupprimerDossier = True

    Catch ex As Exception
        If bPromptErr Then _
            AfficherMsgErreur2(ex, "bSupprimerDossier", _
                "Impossible de supprimer le dossier :" & vbLf & _
                sCheminDossier, sCauseErrPossDossier)
    End Try

End Function

Public Function sDossierParent$(ByVal sCheminDossier$)

    ' Renvoyer le chemin du dossier parent
    ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp
    ' (à renommer plutot en sCheminDossierParent ?)
    ' Ex. avec un chemin de fichier
    '   C:\Tmp\MonFichier.txt -> C:\Tmp
    ' Ex. avec un chemin de fichier avec filtre
    '   C:\Tmp\*.txt -> C:\Tmp

    sDossierParent = IO.Path.GetDirectoryName(sCheminDossier)

End Function

Public Function sNomDossierFinal$(ByVal sCheminDossier$)

    ' Renvoyer le nom du dernier dossier à partir du chemin du dossier 
    ' Exemples :
    ' C:\Tmp\Tmp\MonDossier -> MonDossier
    ' C:\MonDossier\        -> MonDossier
    ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé)

    sNomDossierFinal = sCheminDossier
    sCheminDossier = sEnleverSlashFinal(sCheminDossier)
    Dim iPosDossier% = sCheminDossier.LastIndexOf("\")
    If iPosDossier < 0 Then Exit Function
    sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1)

End Function

Public Function sExtraireChemin$(ByVal sCheminFichier$, _
    Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", _
    Optional ByRef sNomFichierSansExt$ = "")

    ' Retourner le chemin du fichier passé en argument
    ' Non compris le caractère \
    ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension
    ' Exemple :
    ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier

    sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier)
    sNomFichier = IO.Path.GetFileName(sCheminFichier)
    sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier)
    sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt)

End Function

Public Function sNomDossierParent$(ByVal sCheminDossierOuFichier$, _
    Optional ByVal sCheminReference$ = "")

    ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier 
    ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier
    '  sauf si le dossier parent n'existe pas : chemin de référence
    ' Exemples avec un dossier :
    ' C:\Tmp\Tmp\MonDossier     -> \Tmp\MonDossier
    ' C:\MonDossier             -> \MonDossier
    ' Exemples avec un fichier :
    ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt
    ' C:\MonFichier.txt         -> \MonFichier.txt

    sNomDossierParent = ""
    Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\")
    If iPosDossier < 0 Then Exit Function
    sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier)

    ' Si c'est le chemin de référence, on le renvoit tel quel
    Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier)
    If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function

    Dim iFin% = iPosDossier - 1
    Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin)
    If iPosDossierParent < 0 Then Exit Function
    sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent)

End Function

Public Function sCheminRelatif$(ByVal sCheminFichier$, ByVal sCheminReference$)

    ' Renvoyer le chemin relatif au chemin de référence
    '  à partir du chemin complet du fichier

    ' Exemples avec C:\ pour le chemin de référence
    ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt
    ' C:\MonFichier.txt         -> \MonFichier.txt

    ' Exemple avec C:\Tmp1 pour le chemin de référence
    ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt

    sCheminReference = sEnleverSlashFinal(sCheminReference)
    sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length)

End Function

Public Function sEnleverSlashFinal$(ByVal sChemin$)

    ' Enlever le slash final à la fin du chemin, le cas échéant

    If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _
        sEnleverSlashFinal = "" : Exit Function
    If sChemin.EndsWith("\") Then
        sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1)
    Else
        sEnleverSlashFinal = sChemin
    End If

End Function

Public Function sEnleverSlashInitial$(ByVal sChemin$)

    ' Enlever le slash au début du chemin, le cas échéant

    If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _
        sEnleverSlashInitial = "" : Exit Function
    If sChemin.StartsWith("\") Then
        sEnleverSlashInitial = sChemin.Substring(1)
    Else
        sEnleverSlashInitial = sChemin
    End If

End Function

Public Function bCopierArbo(ByVal sSrc$, ByVal sDest$, _
    ByRef bStatut As Boolean, _
    ByRef sListeErr$, Optional ByVal sListeErrExcep$ = "") As Boolean

    ' Copier une arborescence de fichiers
    '  en retournant bStatut : Succès ou Echec de la fonction récursive
    ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est
    '  indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers
    '  de ce rapport si on sait déjà qu'on ne pourra les copier)

    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)
        Exit Function
    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

    bCopierArbo = bStatut

End Function

Public Function sLecteurDossier$(ByVal sDossier$)

    ' Renvoyer le lecteur du dossier sans \ à la fin
    ' Exemple : C:\Tmp -> C:

    sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier))

End Function

#End Region

#Region "Gestion de la lecture et de l'écriture de fichiers"

' 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

Public Function sLireFichier$(ByVal sCheminFichier$)

    ' Lire et renvoyer le contenu d'un fichier

    sLireFichier = ""
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function

    Dim fs As IO.FileStream = Nothing
    Dim sr As IO.StreamReader = Nothing
    Dim sbContenu As New StringBuilder
    Dim bDebut As Boolean = False
    Try
        ' Même avec IO.FileShare.Read, impossible de lire un fichier verrouillé par Excel
        fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _
            IO.FileAccess.Read)
        ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv
        sr = 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
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "sLireFichier")
        Exit Function
    Finally
        If Not (sr Is Nothing) Then sr.Close()
        If Not (fs Is Nothing) Then fs.Close()
    End Try
    sLireFichier = sbContenu.ToString

End Function

Public Function sbLireFichier(ByVal sCheminFichier$) As StringBuilder

    ' Lire et renvoyer le contenu d'un fichier

    sbLireFichier = New StringBuilder
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function

    Dim fs As IO.FileStream = Nothing
    Dim sr As IO.StreamReader = Nothing
    Dim bDebut As Boolean = False
    Try
        fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _
            IO.FileAccess.Read)
        ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv
        sr = 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
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "sbLireFichier")
        Exit Function
    Finally
        If Not (sr Is Nothing) Then sr.Close()
        If Not (fs Is Nothing) Then fs.Close()
    End Try

End Function

Public Function asLireFichier(ByVal sCheminFichier$) As String()

    ' Lire et renvoyer le contenu d'un fichier
    asLireFichier = Nothing
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function
    asLireFichier = IO.File.ReadAllLines(sCheminFichier, _
        Encoding.GetEncoding(iCodePageWindowsLatin1252))

End Function

Public Function bEcrireFichier(ByVal sCheminFichier$, _
    ByVal sbContenu As StringBuilder) 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
        Exit Function
    End If

    Dim sw As IO.StreamWriter = Nothing
    Try
        sw = New IO.StreamWriter(sCheminFichier, append:=False, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sbContenu.ToString())
        sw.Close()
        bEcrireFichier = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bEcrireFichier", _
            "Impossible d'écrire les données dans le fichier :" & _
            vbCrLf & sCheminFichier)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bEcrireFichier(ByVal sCheminFichier$, ByVal sContenu$, _
    Optional ByVal bEncodageDefaut As Boolean = False, _
    Optional ByVal bEncodageISO_8859_1 As Boolean = False) 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
        Exit Function
    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 ø
            sw = New IO.StreamWriter(sCheminFichier, append:=False)
        ElseIf bEncodageISO_8859_1 Then
            sw = New IO.StreamWriter(sCheminFichier, append:=False, _
                Encoding:=Encoding.GetEncoding("ISO-8859-1"))
        Else
            ' Encodage par défaut de VB6 et de Windows en français
            sw = New IO.StreamWriter(sCheminFichier, append:=False, _
                Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        End If
        sw.Write(sContenu)
        sw.Close()
        bEcrireFichier = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bEcrireFichier", _
            "Impossible d'écrire les données dans le fichier :" & _
            vbCrLf & sCheminFichier)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bAjouterFichier(ByVal sCheminFichier$, ByVal sContenu$, _
    Optional ByVal bPrompt As Boolean = True, _
    Optional ByRef sMsgErr$ = "") As Boolean

    Dim sw As IO.StreamWriter = Nothing
    Try
        sw = New IO.StreamWriter(sCheminFichier, append:=True, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sContenu)
        sw.Close()
        bAjouterFichier = 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)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bAjouterFichier(ByVal sCheminFichier$, _
    ByVal sbContenu As StringBuilder) As Boolean

    Dim sw As IO.StreamWriter = Nothing
    Try
        sw = New IO.StreamWriter(sCheminFichier, append:=True, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sbContenu.ToString())
        sw.Close()
        bAjouterFichier = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bAjouterFichier", _
            "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bReencoder(ByVal sCheminFichier$) As Boolean

    ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf)
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function
    Dim sb As StringBuilder = sbLireFichier(sCheminFichier)
    If sb.Length = 0 Then Exit Function
    bReencoder = bEcrireFichier(sCheminFichier, sb.Append(vbCrLf))

End Function

#End Region

#Region "Divers"

Public Function asArgLigneCmd(ByVal sFichiers$) As String()

    ' Retourner les arguments de la ligne de commande

    Dim asArgs$() = Nothing

    'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg

    ' Parser les noms cours : facile
    'asArgs = Split(Command, " ")

    ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers)
    ' Chaque nom long de fichier est entre guillemets : ""
    '  une fois le nom traité, les guillemets sont enlevés
    ' S'il y a un non court parmi eux, il n'est pas entre guillemets

    Const sGm$ = """" ' Un seul " en fait
    'sGm = Chr$(34) ' Guillemets
    Dim iNbArg%, sFichier$, sSepar$
    Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2%
    Dim bFin As Boolean, bNomLong As Boolean
    sCmd = sFichiers 'Command$
    iLen = Len(sCmd)
    iDeb = 1
    Do

        bNomLong = False : sSepar = " "
        ' Si le premier caractère est un guillement, c'est un nom long
        If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True : sSepar = sGm

        iDeb2 = iDeb
        ' Supprimer les guillemets dans le tableau de fichiers
        If bNomLong Then iDeb2 += 1
        ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2
        iFin = InStr(iDeb2 + 1, sCmd, sSepar)
        ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande
        If iFin = 0 Then bFin = True : iFin = iLen + 1

        sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2))
        If sFichier <> "" Then
            ReDim Preserve asArgs(iNbArg)
            asArgs(iNbArg) = sFichier
            iNbArg += 1
        End If

        If bFin Or iFin = iLen Then Exit Do

        iDeb = iFin + 1
        If bNomLong Then iDeb = iFin + 2

    Loop

    Const iCodeGuillemets% = 34
    Dim iNumArg%
    For iNumArg = 0 To UBound(asArgs)
        asArgs(iNumArg) = Trim$(asArgs(iNumArg))
        Dim sArg$ = asArgs(iNumArg)
        ' S'il y avait 2 guillemets, il n'en reste plus qu'un
        '  on le converti en chaîne vide
        If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then
            asArgs(iNumArg) = ""
        End If
    Next iNumArg

    asArgLigneCmd = asArgs

End Function

Public Function sConvNomDos$(ByVal sChaine$, _
    Optional ByVal bLimit8Car As Boolean = False, _
    Optional ByVal bConserverSignePlus As Boolean = False)

    ' Remplacer les caractères interdits pour les noms de fichiers DOS
    '  et retourner un nom de fichier 8.3 correcte 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 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

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 Function bAjouterTypeFichier(ByVal sExtension$, ByVal sTypeFichier$, _
    Optional ByVal sDescriptionExtension$ = "", _
    Optional ByVal bEnlever As Boolean = False) As Boolean

    ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot
    '  pour associer une extension de ficier à une application par défaut
    ' (via le double-clic ou bien le menu contextuel Ouvrir)
    ' Exemple : associer .dat à mon application.exe

    Try

        If bEnlever Then
            If bCleRegistreCRExiste(sExtension) Then
                Registry.ClassesRoot.DeleteSubKeyTree(sExtension)
            End If
        Else
            If Not bCleRegistreCRExiste(sExtension) Then
                Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension)
                    rk.SetValue("", sTypeFichier)
                    If sDescriptionExtension.Length > 0 Then
                        rk.SetValue("Content Type", sDescriptionExtension)
                    End If
                End Using 'rk.Close()
            End If
        End If
        bAjouterTypeFichier = True

    Catch ex As Exception
        AfficherMsgErreur2(ex, "bAjouterTypeFichier")
    End Try

End Function

Public Function bAjouterMenuContextuel(ByVal sTypeFichier$, ByVal sCmd$, _
    Optional ByVal bPrompt As Boolean = True, _
    Optional ByVal bEnlever As Boolean = False, _
    Optional ByVal sDescriptionCmd$ = "", _
    Optional ByVal sCheminExe$ = "", _
    Optional ByVal sCmdDef$ = """%1""", _
    Optional ByVal sDescriptionTypeFichier$ = "") 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 & "\shell\" & sCmd

        If bEnlever Then
            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
            bAjouterMenuContextuel = True
            Exit Function
        End If

        Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd)
            rk.SetValue("", sDescriptionCmd)
        End Using 'rk.Close()

        Dim sCleCmd$ = sTypeFichier & "\shell\" & sCmd & "\command"
        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)

        bAjouterMenuContextuel = True

    Catch ex As Exception
        AfficherMsgErreur2(ex, "bAjouterMenuContextuel")
    End Try

End Function

Public Function bCleRegistreCRExiste(ByVal sCle$, _
    Optional ByVal sSousCle$ = "") As Boolean

    ' Vérifier si une clé ClassesRoot existe dans la base de registre
    Try
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey( _
            sCle & "\\" & sSousCle)
            If IsNothing(rkCRCle) Then Exit Function
        End Using ' rkCRCle.Close() est automatiquement appelé
        bCleRegistreCRExiste = True
    Catch
    End Try

End Function

Public Function bCleRegistreLMExiste(ByVal sCle$, _
    Optional ByVal sSousCle$ = "", _
    Optional ByRef sValSousCle$ = "", _
    Optional ByVal sNouvValSousCle$ = "") As Boolean

    ' Vérifier si une clé/sous-clé LocalMachine existe dans la base de registre
    sValSousCle = ""
    Try
        Dim bEcriture As Boolean = False
        If sNouvValSousCle.Length > 0 Then bEcriture = True
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sCle, _
            writable:=bEcriture)
            Dim oVal As Object = rkLMCle.GetValue(sSousCle)
            ' Si la sous-clé n'existe pas, oVal reste à Nothing 
            '  (aucune exception n'est générée)
            If IsNothing(oVal) Then Exit Function
            Dim sValSousCle0$ = CStr(oVal)
            ' Il faut aussi tester ce cas obligatoirement
            If IsNothing(sValSousCle0) Then Exit Function
            sValSousCle = sValSousCle0
            If bEcriture Then
                oVal = CInt(sNouvValSousCle)
                rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord)
            End If
        End Using ' rkLMCle.Close() est automatiquement appelé
        bCleRegistreLMExiste = True ' On peut lire cette clé, donc elle existe
    Catch
    End Try

End Function

Public Function bCleRegistreCUExiste(ByVal sCle$, _
    Optional ByVal sSousCle$ = "", _
    Optional ByRef sValSousCle$ = "") As Boolean

    ' Vérifier si une clé/sous-clé CurrentUser existe dans la base de registre
    '  et si oui renvoyer la valeur de la sous-clé
    sValSousCle = ""
    Try
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle)
            Dim oVal As Object = rkCUCle.GetValue(sSousCle)
            ' Si la sous-clé n'existe pas, oVal reste à Nothing 
            '  (aucune exception n'est générée)
            If IsNothing(oVal) Then Exit Function
            Dim sValSousCle0$ = CStr(oVal)
            ' Il faut aussi tester ce cas obligatoirement
            If IsNothing(sValSousCle0) Then Exit Function
            sValSousCle = sValSousCle0
        End Using ' rkCUCle.Close() est automatiquement appelé
        bCleRegistreCUExiste = True ' On peut lire cette clé, donc elle existe
    Catch
    End Try

End Function

Public Function asListeSousClesCU(ByVal sCle$) As String()

    ' Renvoyer la liste des sous-clés de type CurrentUser
    asListeSousClesCU = Nothing
    Try
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle)
            If IsNothing(rkCUCle) Then Exit Function
            asListeSousClesCU = rkCUCle.GetSubKeyNames
        End Using ' rkCUCle.Close() est automatiquement appelé
    Catch
    End Try

End Function

End Module


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

Public Sub New(ByVal sort As String)

    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)
        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("Les membres de la classe à comparer ne doivent pas être privés !", _
                        MsgBoxStyle.Critical, "UniversalComparer:Compare")
                    m_bMsg = True
                End If
                Exit Function
            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
End Structure

End Class