XmlStruct v1.0.1.*

Table des procédures

1 - AssemblyInfo.vb

2 - modDepart.vb
    2.1 - Private Function bIndenterXml
    2.2 - Private Function bNormaliser
    2.3 - Private Function bSupprimerAttributs
    2.4 - Private Function bVerifierXmlDTD
    2.5 - Private Function bVerifierXmlSchema
    2.6 - Private Function Normaliser_bListerNoeudsEnfants
    2.7 - Private Function SupprimerAttr_bListerNoeudsEnfants
    2.8 - Private Sub AjouterMenuCtx
    2.9 - Private Sub AjouterMenuCtx_
    2.10 - Private Sub Depart
    2.11 - Private Sub EnleverMenuCtx
    2.12 - Private Sub EnleverMenuCtx_
    2.13 - Private Sub Normaliser_Noeud_Main
    2.14 - Private Sub SupprimerAttr_NoeudXml
    2.15 - Private Sub SupprimerAttr_NoeudXml_Main
    2.16 - Private Sub ValidationCallBack
    2.17 - Private Sub ValidationCallBack_Schema
    2.18 - Private Sub VerifierMenuCtx
    2.19 - Public Function bIgnorerDTD
    2.20 - Public Function bVerifAppliDejaOuverte
    2.21 - Public Sub Main
    2.22 - Public Sub RenommerNoeudXml

3 - modXml2DTD.vb
    3.1 - Private Function bListerNoeudsEnfants
    3.2 - Private Function bListerNoeudsEnfants0
    3.3 - Private Sub IndexerNoeud
    3.4 - Private Sub ListerNoeudsEnfantsHt
    3.5 - Private Sub TrierArbo
    3.6 - Private Sub VerifierNoeudXml
    3.7 - Public Function bExtraireDTD

4 - clsNoeudXml.vb

5 - clsHTTri.vb
    5.1 - Public Function Trier

6 - UniversalComparer.vb
    6.1 - Public Function Compare
    6.2 - Public Function Compare
    6.3 - Public Sub New

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

8 - modUtilReg.vb
    8.1 - Public Function asListeSousClesCU
    8.2 - Public Function bAjouterMenuContextuel
    8.3 - Public Function bAjouterTypeFichier
    8.4 - Public Function bCleRegistreCRExiste
    8.5 - Public Function bCleRegistreCUExiste
    8.6 - Public Function bCleRegistreLMExiste

9 - modUtilFichier.vb
    9.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible
    9.2 - Public Function asArgLigneCmd
    9.3 - Public Function bAjouterFichier
    9.4 - Public Function bAjouterFichier
    9.5 - Public Function bChoisirFichier
    9.6 - Public Function bCopierArbo
    9.7 - Public Function bCopierFichier
    9.8 - Public Function bDeplacerDossier
    9.9 - Public Function bDeplacerFichiers2
    9.10 - Public Function bDeplacerFichiers3
    9.11 - Public Function bDossierExiste
    9.12 - Public Function bEcrireFichier
    9.13 - Public Function bEcrireFichier
    9.14 - Public Function bFichierExiste
    9.15 - Public Function bFichierExisteFiltre
    9.16 - Public Function bReencoder
    9.17 - Public Function bRenommerDossier
    9.18 - Public Function bRenommerFichier
    9.19 - Public Function bSupprimerDossier
    9.20 - Public Function bSupprimerFichier
    9.21 - Public Function bVerifierCreerDossier
    9.22 - Public Function iNbFichiersFiltres%
    9.23 - Public Function sbLireFichier
    9.24 - Public Function sCheminRelatif$
    9.25 - Public Function sConvNomDos$
    9.26 - Public Function sDossierParent$
    9.27 - Public Function sEnleverSlashFinal$
    9.28 - Public Function sEnleverSlashInitial$
    9.29 - Public Function sExtraireChemin$
    9.30 - Public Function sFormaterNumerique$
    9.31 - Public Function sFormaterTailleOctets$
    9.32 - Public Function sLecteurDossier$
    9.33 - Public Function sLireFichier$
    9.34 - Public Function sNomDossierFinal$
    9.35 - Public Function sNomDossierParent$
    9.36 - Public Sub OuvrirAppliAssociee
    9.37 - Public Sub ProposerOuvrirFichier



AssemblyInfo.vb



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

Imports System.Reflection

<Assembly: AssemblyTitle("XmlStruct")> 
<Assembly: AssemblyDescription( _
    "XmlStruct : Extraire et comparer la structure de documents xml")> 
<Assembly: AssemblyCompany("ORS Production")> 
<Assembly: AssemblyProduct("XmlStruct")> 
<Assembly: AssemblyCopyright("© 2008 ORS Production")> 
<Assembly: AssemblyTrademark("XmlStruct")> 

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


modDepart.vb



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

' XmlStruct : Extraire et comparer la structure de documents xml

' Documentation : XmlStruct.html
' http://patrice.dargenton.free.fr/CodesSources/XmlStruct.html
' http://patrice.dargenton.free.fr/CodesSources/XmlStruct.vbproj.html
' www.vbfrance.com/listeauteur2.aspx?ID=1124
' Par Patrice Dargenton : patrice.dargenton@free.fr
' http://patrice.dargenton.free.fr/index.html
' http://patrice.dargenton.free.fr/CodesSources/index.html
' Version 1.01 du 07/09/2008

' 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.Xml
Imports System.Text ' Pour StringBuilder

Module modDepart

Public Const sTitreMsg$ = "XmlStruct"
Public Const sTitreMsgDescription$ = " : Analyser la structure d'un fichier Xml"

' Avec VBExpress, pour choisir le mode debug ou pas, il faut
'  sélectionner le menu Build : Configuration Manager... Debug ou Release
' Pour voir ce menu, il faut afficher les options avancées :
'  menu Tools : Options... : Projets and Solutions : "Show Advanced Build Configuration"
#If DEBUG Then
    Public Const bDebug As Boolean = True
    Public Const bRelease As Boolean = False
#Else
    Public Const bDebug As Boolean = False
    Public Const bRelease As Boolean = True
#End If

#Region "Déclarations"

Private m_bAppliDejaOuverte, m_bVerifAppliDejaOuverte As Boolean

Private m_htTypesErr As Hashtable ' Regrouper les types d'erreur
Private m_bErr As Boolean
Private m_sbErr As StringBuilder

Private m_bSauverXml As Boolean
Private m_xmlDoc As XmlDocument

Private m_sb As StringBuilder

Public Const sBaliseContenu$ = "#PCDATA" ' Parsed Character DATA
Public Const sBaliseCommentaire$ = "#comment"
Public Const sBaliseDonnees$ = "#cdata-section"
Public Const sBaliseTexte$ = "#text"

Public Enum TypeConv
    Indenter
    Xml2DTD
    Xml2DTDComp
    SupprAttr
    VerifierDTD
    VerifierSchema
    Normaliser
End Enum

' Types de conversion
Private Const sIndenter$ = "Indenter" ' Xml bien indenté pour Windows
Private Const sXml2DTD$ = "Xml2DTD"     ' Schéma au format DTD
Private Const sXml2DTDComp$ = "Xml2DTDComp" ' Schéma au format DTD (pour comparaison seulement)
Private Const sSupprAttr$ = "SupprAttr" ' Xml sans les attributs (ni les commentaires)
Private Const sVerifierDTD$ = "VerifierDTD"
Private Const sVerifierSchema$ = "VerifierSchema"
' Normaliser la casse des balises en minucules pour la 
'  vérification et comparaison de structure
Private Const sNormaliser$ = "Normaliser"

' Menus contextuels
Private Const sMenuCtx_TypeFichierAiml$ = "aiml_auto_file"
Private Const sMenuCtx_TypeFichierXml$ = "xmlfile"

Private Const sMenuCtx_CleCmdIndenter$ = "Indenter"
Private Const sMenuCtx_CleCmdIndenterDescription$ = _
    "Corriger la présentation Xml"

Private Const sMenuCtx_CleCmdNormaliser$ = "Normaliser"
Private Const sMenuCtx_CleCmdNormaliserDescription$ = _
    "Normaliser la casse des balises en minuscules"

Private Const sMenuCtx_CleCmdSupprAttr$ = "SupprimerAttributs"
Private Const sMenuCtx_CleCmdSupprAttrDescription$ = _
    "Supprimer les attributs Xml"

Private Const sMenuCtx_CleCmdExtraireStructure$ = "ExtraireStructureDTD"
Private Const sMenuCtx_CleCmdExtraireStructureDescription$ = _
    "Extraire la structure au format DTD"
Private Const sMenuCtx_CleCmdExtraireStructureComp$ = "ExtraireStructureDTDComp"
Private Const sMenuCtx_CleCmdExtraireStructureCompDescription$ = _
    "Extraire la structure simple au format DTD"

Private Const sMenuCtx_CleCmdVerifierDTD$ = "VerifierDTD"
Private Const sMenuCtx_CleCmdVerifierDTDDescription$ = _
    "Vérifier la validité selon la DTD"

Private Const sMenuCtx_CleCmdVerifierSchema$ = "VerifierSchema"
Private Const sMenuCtx_CleCmdVerifierSchemaDescription$ = _
    "Vérifier la validité selon le schéma"


Private Const sPostFixe_SansAttribut$ = "_SansAttr"
Private Const sPostFixe_Normalise$ = "_Norm"
Private Const sPostFixe_SansDTD$ = "_SansDTD"
Public Const sPostFixe_Dedoub$ = "_Dedoub"

#End Region

#Region "Initialisations"

Public Sub Main()

    ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE
    ' Sinon, ce n'est pas pratique de retrouver la ligne du bug :
    '  il faut cocher Thrown dans le menu Debug:Exception... pour les 2 lignes
    '  (dans ce cas, il peut y avoir beaucoup d'interruptions selon la logique 
    '   de programmation : mieux vaut prévenir les erreurs que de les traiter)
    ' C'était plus simple avec On Error Goto X, car on pouvait
    '  désactiver la gestion d'erreur avec une simple constante bTrapErr.
    If bDebug Then Depart() : Exit Sub

    ' Attention : En mode Release il faut un Try Catch ici  
    '  car sinon il n'y a pas de gestion d'erreur !
    ' (.Net renvoie un message d'erreur équivalent 
    '  à un plantage complet sans explication)
    Try
        Depart()
    Catch ex As Exception
        AfficherMsgErreur2(ex, "Depart " & sTitreMsg)
    End Try

End Sub

Private Sub Depart()

    ' Extraire les options passées en argument de la ligne de commande
    ' Cette fct ne marche pas avec des chemins contenant des espaces, même entre guillemets
    'Dim asArgs$() = Environment.GetCommandLineArgs()
    Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command
    Dim iTypeConv As TypeConv = TypeConv.Xml2DTD
    Dim sCheminFichier$ = ""
    Dim bSyntaxeOk As Boolean = False
    Dim iNbArguments% = 0
    If sArg0.Length > 0 Then
        Dim asArgs$() = asArgLigneCmd(sArg0)
        iNbArguments = UBound(asArgs) + 1
        If iNbArguments <= 2 Then bSyntaxeOk = True
        Dim i%
        For i = 0 To iNbArguments - 1
            If asArgs(i) = sIndenter Then
                iTypeConv = TypeConv.Indenter
            ElseIf asArgs(i) = sXml2DTD Then
                iTypeConv = TypeConv.Xml2DTD
            ElseIf asArgs(i) = sXml2DTDComp Then
                iTypeConv = TypeConv.Xml2DTDComp
            ElseIf asArgs(i) = sSupprAttr Then
                iTypeConv = TypeConv.SupprAttr
            ElseIf asArgs(i) = sVerifierDTD Then
                iTypeConv = TypeConv.VerifierDTD
            ElseIf asArgs(i) = sVerifierSchema Then
                iTypeConv = TypeConv.VerifierSchema
            ElseIf asArgs(i) = sNormaliser Then
                iTypeConv = TypeConv.Normaliser
            Else
                sCheminFichier = asArgs(i)
                If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then _
                    bSyntaxeOk = False
            End If
        Next i

    End If
    If Not bSyntaxeOk Then
        Dim sMsg$ = _
            "Syntaxe : Chemin du fichier Xml à traiter CodeMenu" & vbCrLf & _
            "Codes menus possibles :" & vbCrLf & _
            "Indenter : " & sMenuCtx_CleCmdIndenterDescription & vbCrLf & _
            "Normaliser : " & sMenuCtx_CleCmdNormaliserDescription & vbCrLf & _
            "SupprAttr : " & sMenuCtx_CleCmdSupprAttrDescription & vbCrLf & _
            "Xml2DTD : " & sMenuCtx_CleCmdExtraireStructureDescription & vbCrLf & _
            "Xml2DTDComp : " & sMenuCtx_CleCmdExtraireStructureCompDescription & vbCrLf & _
            "VerifierDTD : " & sMenuCtx_CleCmdVerifierDTDDescription & vbCrLf & _
            "VerifierSchema : " & sMenuCtx_CleCmdVerifierSchemaDescription & vbCrLf & _
            "Exemples : " & vbCrLf & _
            "XmlStruct.exe C:\Tmp\MonFichierXml.xml Indenter" & vbCrLf & _
            "XmlStruct.exe ""C:\Tmp\Mon Fichier Xml.xml"" Xml2DTD" & vbCrLf & _
            "Sinon ajouter les menus contextuels via le menu dédié" & vbCrLf & _
            "(utilisation des menus contextuels avec le bouton droit" & vbCrLf & _
            " de la souris dans l'explorateur de fichier)" & vbCrLf & _
            "(message copié dans le presse-papier)"
        CopierPressePapier(sMsg)
        MsgBox(sMsg, MsgBoxStyle.Information, sTitreMsg & sTitreMsgDescription)
        VerifierMenuCtx()
        Exit Sub
    End If

    If iTypeConv = TypeConv.Indenter Then
        bIndenterXml(sCheminFichier)
        Exit Sub
    ElseIf iTypeConv = TypeConv.SupprAttr Then
        bSupprimerAttributs(sCheminFichier)
        Exit Sub
    ElseIf iTypeConv = TypeConv.VerifierDTD Then
        bVerifierXmlDTD(sCheminFichier)
        Exit Sub
    ElseIf iTypeConv = TypeConv.VerifierSchema Then
        bVerifierXmlSchema(sCheminFichier)
        Exit Sub
    ElseIf iTypeConv = TypeConv.Normaliser Then
        bNormaliser(sCheminFichier)
        Exit Sub
    End If

    Dim bGenererDTDNonDedoub As Boolean = False
    If iTypeConv = TypeConv.Xml2DTDComp Then
        bGenererDTDNonDedoub = True
    End If

    bExtraireDTD(sCheminFichier, bGenererDTDNonDedoub)

End Sub

Public Function bVerifAppliDejaOuverte() As Boolean

    ' N'afficher qu'une seule fois un message si on a lancé
    '  l'appli sur une multi-sélection de fichier à traiter
    ' Note : il se peut qu'aucun message ne soit affiché

    If Not m_bVerifAppliDejaOuverte Then
        ' Ne vérifier qu'une seule fois, à la fin du traitement
        m_bAppliDejaOuverte = bAppliDejaOuverte()
        m_bVerifAppliDejaOuverte = True
    End If

    bVerifAppliDejaOuverte = m_bAppliDejaOuverte

End Function

Private Sub VerifierMenuCtx()

    Dim sCleDescriptionCmd$ = sMenuCtx_TypeFichierXml & "\shell\" & _
        sMenuCtx_CleCmdExtraireStructure
    If bCleRegistreCRExiste(sCleDescriptionCmd) Then
        EnleverMenuCtx()
    Else
        AjouterMenuCtx()
    End If

End Sub

Private Sub AjouterMenuCtx()

    If MsgBoxResult.Cancel = MsgBox("Ajouter les menus contextuels ?", _
        MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub

    AjouterMenuCtx_(sMenuCtx_TypeFichierXml)
    AjouterMenuCtx_(sMenuCtx_TypeFichierAiml)

End Sub

Private Sub AjouterMenuCtx_(ByVal sMenuCtx_TypeFichier$)

    Dim sCheminExe$ = Application.ExecutablePath
    Const bPrompt As Boolean = False
    Const sChemin$ = """%1"""
    ' Préfixer tous les menus ctx pour informer leur provenance
    Const sPrefixeMenu$ = "XmlStruct : "

    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdIndenter, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdIndenterDescription, sCheminExe, _
        sChemin & " " & sIndenter)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdExtraireStructure, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdExtraireStructureDescription, sCheminExe, _
        sChemin & " " & sXml2DTD)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdExtraireStructureComp, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdExtraireStructureCompDescription, sCheminExe, _
        sChemin & " " & sXml2DTDComp)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdSupprAttr, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdSupprAttrDescription, sCheminExe, _
        sChemin & " " & sSupprAttr)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVerifierDTD, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdVerifierDTDDescription, sCheminExe, _
        sChemin & " " & sVerifierDTD)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVerifierSchema, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdVerifierSchemaDescription, sCheminExe, _
        sChemin & " " & sVerifierSchema)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdNormaliser, _
        bPrompt, , sPrefixeMenu & sMenuCtx_CleCmdNormaliserDescription, sCheminExe, _
        sChemin & " " & sNormaliser)

End Sub

Private Sub EnleverMenuCtx()

    If MsgBoxResult.Cancel = MsgBox("Enlever les menus contextuels ?", _
        MsgBoxStyle.OkCancel Or MsgBoxStyle.Question) Then Exit Sub

    EnleverMenuCtx_(sMenuCtx_TypeFichierXml)
    EnleverMenuCtx_(sMenuCtx_TypeFichierAiml)

End Sub

Private Sub EnleverMenuCtx_(ByVal sMenuCtx_TypeFichier$)

    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdIndenter, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdExtraireStructure, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdExtraireStructureComp, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdSupprAttr, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVerifierDTD, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdVerifierSchema, _
        bEnlever:=True, bPrompt:=False)
    bAjouterMenuContextuel(sMenuCtx_TypeFichier, sMenuCtx_CleCmdNormaliser, _
        bEnlever:=True, bPrompt:=False)

End Sub

#End Region

#Region "Suppression des attributs d'un fichier xml"

Private Function bSupprimerAttributs(ByVal sCheminXml$) As Boolean

    If Not bIgnorerDTD(sCheminXml) Then Exit Function

    Dim xmlDoc As New XmlDocument
    m_xmlDoc = xmlDoc
    Try
        xmlDoc.Load(sCheminXml)
    Catch ex As Exception
        AfficherMsgErreur2(ex, "bSupprimerAttributs", "Fichier : " & sCheminXml)
        Exit Function
    End Try

    m_bSauverXml = False
    Dim iNiv% = 1
    m_sb = New StringBuilder
    For Each xmlNodeEnfant As XmlNode In xmlDoc.ChildNodes
        ' Pas pour xml
        If xmlNodeEnfant.Name <> "xml" Then
            ' On ne peut enlever les attributs d'un noeud racine si la DTD est présente
            '  il faut l'enlever au préalable
            SupprimerAttr_NoeudXml(xmlNodeEnfant)
        End If
        Dim sArboEnfant$ = xmlNodeEnfant.Name & "\"
        SupprimerAttr_bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)
    Next

    Dim sFichier0$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
    Dim sChemin0$ = IO.Path.GetDirectoryName(sCheminXml)
    Dim sCheminXmlSansAttr$ = sChemin0 & "\" & _
        sFichier0 & sPostFixe_SansAttribut & ".xml"
    xmlDoc.Save(sCheminXmlSansAttr)

    bSupprimerAttributs = True

    If bVerifAppliDejaOuverte() Then Exit Function

    MsgBox("Une version sans attributs du fichier xml a été générée !", _
        MsgBoxStyle.Exclamation, sTitreMsg)

End Function

Private Function SupprimerAttr_bListerNoeudsEnfants(ByVal xmlNodeParent As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$) As Boolean

    If Not xmlNodeParent.HasChildNodes Then
        Exit Function
    End If

    Dim xmlNodeEnfant As XmlNode = Nothing
    For Each xmlNodeEnfant In xmlNodeParent.ChildNodes
        SupprimerAttr_NoeudXml_Main(xmlNodeEnfant, iNiv, sArboParent)
    Next

    ' Il n'y a plus d'enfant suivant, à moins qu'un noeud ait été corrigé, attention !
    Dim xmlNodeEnfantReste As XmlNode = xmlNodeEnfant.NextSibling
ResteNoeuds:
    If Not IsNothing(xmlNodeEnfantReste) Then
        'Debug.WriteLine(iNiv & ":" & sArboParent & ":" & xmlNodeEnfantReste.Value)
        SupprimerAttr_NoeudXml_Main(xmlNodeEnfantReste, iNiv, sArboParent)
        xmlNodeEnfantReste = xmlNodeEnfantReste.NextSibling
        GoTo ResteNoeuds
    End If

    SupprimerAttr_bListerNoeudsEnfants = True

End Function

Private Sub SupprimerAttr_NoeudXml_Main(ByRef xmlNodeEnfant As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$)

    ' Penser à mettre ByRef xmlNodeEnfant car le noeud peut être renommé

    Dim sNoeudEnfant$ = xmlNodeEnfant.Name
    Dim sArboEnfant$ = sArboParent & sNoeudEnfant & "\"
    SupprimerAttr_NoeudXml(xmlNodeEnfant)
    SupprimerAttr_bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)

End Sub

Private Sub SupprimerAttr_NoeudXml(ByRef noeudOrig As XmlNode)

    ' Supprimer les attributs d'un noeud xml (en en créant un autre) 
    ' Attention, à la fin on remplace le noeud d'origine par le nouveau :
    '  pensez à mettre ByRef XmlNode au lieu de ByVal
    '  et attention aussi aux énumérations :
    '   For Each xmlNodeEnfant In xmlNodeParent.ChildNodes :
    '  le noeaud modifié risque d'être manqué

    Dim sNoeudEnfant$ = noeudOrig.Name
    Select Case sNoeudEnfant.ToLower
    Case sBaliseCommentaire : Exit Sub  ' Ignorer les commentaires
    Case sBaliseDonnees : Exit Sub
    Case sBaliseTexte : Exit Sub
    Case sBaliseContenu.ToLower : Exit Sub
    End Select
    Dim noeudFinal As XmlNode = m_xmlDoc.CreateElement(noeudOrig.Name)
    noeudFinal.InnerXml = noeudOrig.InnerXml
    noeudOrig.ParentNode.ReplaceChild(noeudFinal, noeudOrig)
    noeudOrig = noeudFinal

End Sub

#End Region

#Region "Vérification DTD"

Private Function bVerifierXmlDTD(ByVal sCheminXml$) As Boolean

    ' Vérifier la validité d'un document xml selon sa DTD

    'http://msdn2.microsoft.com/en-us/library/z2adhb2f(VS.80).aspx
    Dim settings As XmlReaderSettings = New XmlReaderSettings()
    settings.ProhibitDtd = False
    settings.ValidationType = ValidationType.DTD
    AddHandler settings.ValidationEventHandler, AddressOf ValidationCallBack

    Try
        Using reader As XmlReader = XmlReader.Create(sCheminXml, settings)
            m_bErr = False
            While reader.Read()
                If m_bErr Then Exit While
            End While
        End Using
    Catch ex As Exception
        AfficherMsgErreur2(ex, "bVerifierXmlDTD")
        Exit Function
    End Try

    If m_bErr Then Exit Function

    bVerifierXmlDTD = True

    If bVerifAppliDejaOuverte() Then Exit Function

    MsgBox("Le document " & IO.Path.GetFileName(sCheminXml) & _
        " est valide selon son DTD !", MsgBoxStyle.Information, sTitreMsg)

End Function

Private Sub ValidationCallBack(ByVal sender As Object, _
    ByVal e As Xml.Schema.ValidationEventArgs)
    MsgBox(e.Message, MsgBoxStyle.Critical, sTitreMsg)
    m_bErr = True
End Sub

#End Region

#Region "Vérification Schéma"

Private Function bVerifierXmlSchema(ByVal sCheminXml$) As Boolean

    ' Vérifier la validité d'un document xml selon son schéma

    ' D'abord vérifier si le document xml a un schéma spécifié
    ' (sinon on ne trouverait aucune erreur)
    Dim xmlDoc As New XmlDocument
    Try
        xmlDoc.Load(sCheminXml)

        Dim sNoeudRacine$ = ""
        Dim bSchemaPresent As Boolean = True
        Dim bNoeudRacine As Boolean = False
        For Each xmlNodeEnfant As XmlNode In xmlDoc.ChildNodes
            If IsNothing(xmlNodeEnfant.Attributes) Then
                If Not bNoeudRacine Then
                    bNoeudRacine = True
                Else
                    bSchemaPresent = False
                    Exit For
                End If
                Continue For
            End If
            sNoeudRacine = xmlNodeEnfant.Name
            bSchemaPresent = False
            For Each attribute As XmlAttribute In xmlNodeEnfant.Attributes()
                If attribute.Name = "xmlns:xsi" Then bSchemaPresent = True
                If attribute.Name = "xsi:noNamespaceSchemaLocation" Then bSchemaPresent = True
            Next
            Exit For
        Next
        If Not bSchemaPresent Then

            If bVerifAppliDejaOuverte() Then
                Dim sChemin$ = IO.Path.GetDirectoryName(sCheminXml) & _
                    "\FichiersSansSchema.txt"
                Dim sLigne$ = IO.Path.GetFileName(sCheminXml) & vbCrLf
                If Not bAjouterFichier(sChemin, sLigne) Then Exit Function
                Exit Function
            End If

            Dim sInfo$ = "Le document " & IO.Path.GetFileName(sCheminXml) & _
                " ne spécifie pas de schéma !"
            sInfo &= vbCrLf & "Ajoutez les attributs suivants sur la première ligne xml :"
            sInfo &= vbCrLf & "<" & sNoeudRacine & _
                " xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:noNamespaceSchemaLocation=""" & _
                sNoeudRacine & ".xsd"">"
            sInfo &= vbCrLf & "(ce message a été copié dans le presse-papier)"
            CopierPressePapier(sInfo)
            MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg)

            Exit Function

        End If

    Catch ex As Exception

        If bVerifAppliDejaOuverte() Then
            Dim sChemin$ = IO.Path.GetDirectoryName(sCheminXml) & _
                "\FichiersNonConformesXml.txt"
            Dim sLigne$ = IO.Path.GetFileName(sCheminXml) & vbCrLf
            If Not bAjouterFichier(sChemin, sLigne) Then Exit Function
            Exit Function
        End If

        Dim sInfo$ = "Le document " & IO.Path.GetFileName(sCheminXml) & _
            " n'est pas conforme à xml !"
        sInfo &= vbCrLf & "Ouvrez le document dans un navigateur pour trouver les erreurs :"
        AfficherMsgErreur2(ex, "bVerifierXmlSchema", sInfo)

        If IO.Path.GetExtension(sCheminXml).ToLower <> ".xml" Then
            ' IE ne veut pas etre associé a des aiml
            Dim sCheminXmlForce$ = IO.Path.ChangeExtension(sCheminXml, ".xml")
            bCopierFichier(sCheminXml, sCheminXmlForce)
            OuvrirAppliAssociee(sCheminXmlForce)
        Else
            OuvrirAppliAssociee(sCheminXml)
        End If

        Exit Function

    End Try

    'http://msdn2.microsoft.com/en-us/library/system.xml.xmlreadersettings.validationtype.aspx
    Dim settings As XmlReaderSettings = New XmlReaderSettings()
    'settings.IgnoreComments = True
    'settings.IgnoreWhitespace = True
    'settings.ValidationFlags = _
    '    Schema.XmlSchemaValidationFlags.AllowXmlAttributes Or _
    '    Schema.XmlSchemaValidationFlags.ProcessIdentityConstraints Or _
    '    Schema.XmlSchemaValidationFlags.ProcessInlineSchema Or _
    '    Schema.XmlSchemaValidationFlags.ProcessSchemaLocation Or _
    '    Schema.XmlSchemaValidationFlags.ReportValidationWarnings
    ' ProcessSchemaLocation : nécessaire pour valider la conformité
    ' ReportValidationWarnings : nécessaire pour détecter la présence du schéma
    settings.ValidationFlags = _
        Schema.XmlSchemaValidationFlags.ProcessSchemaLocation Or _
        Schema.XmlSchemaValidationFlags.ReportValidationWarnings
    settings.ValidationType = ValidationType.Schema
    'Dim sc As Schema.XmlSchemaSet = New Schema.XmlSchemaSet()
    'Dim sNomFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
    'Dim sChemin$ = IO.Path.GetDirectoryName(sCheminXml)
    'Dim sFichier$ = sNomFichier & ".xsd"
    'Dim sCheminXsd$ = sChemin & "\" & sFichier
    'If Not bFichierExiste(sCheminXsd, bPrompt:=True) Then Exit Function
    'sc.Add(Null, sCheminXsd)
    'settings.Schemas = sc
    AddHandler settings.ValidationEventHandler, AddressOf ValidationCallBack_Schema

    m_htTypesErr = New Hashtable

    m_sbErr = New StringBuilder
    Try
        Using reader As XmlReader = XmlReader.Create(sCheminXml, settings)
            m_bErr = False
            While reader.Read()
                'If m_bErr Then Exit While
            End While
        End Using
    Catch ex As Exception
        AfficherMsgErreur2(ex, "bVerifierXmlSchema")
        Exit Function
    End Try

    If Not m_bErr Then

        bVerifierXmlSchema = True

        If bVerifAppliDejaOuverte() Then Exit Function

        MsgBox("Le document " & IO.Path.GetFileName(sCheminXml) & _
            " est valide selon son schéma !", MsgBoxStyle.Information, sTitreMsg)

    Else

        ' Types d'err
        Dim sb As New StringBuilder( _
            "Types d'erreur rencontrés lors de la validation du schéma :" & vbCrLf & vbCrLf)
        Dim de As IDictionaryEnumerator = m_htTypesErr.GetEnumerator
        While de.MoveNext()
            Dim sErr$ = "- " & CStr(de.Key) & vbCrLf
            Dim sLignesEtPos$ = "  --> " & CStr(m_htTypesErr(de.Key))
            sb.Append(sErr & sLignesEtPos & "." & vbCrLf & vbCrLf)
        End While
        sb.Append(vbCrLf & vbCrLf)

        sb.Append( _
            "Pensez à ouvrir le fichier xml dans Visual Studio 2008, c'est plus pratique !").Append(vbCrLf)

        Dim sNomFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
        Dim sChemin$ = IO.Path.GetDirectoryName(sCheminXml)
        Dim sFichier$ = sNomFichier & "_Erreurs.txt"
        Dim sCheminErr$ = sChemin & "\" & sFichier
        If Not bEcrireFichier(sCheminErr, sb) Then Exit Function

        If bVerifAppliDejaOuverte() Then Exit Function

        ProposerOuvrirFichier(sCheminErr)

    End If

End Function

Private Sub ValidationCallBack_Schema(ByVal sender As Object, _
    ByVal e As Xml.Schema.ValidationEventArgs)

    Dim sMsgErr$ = ""
    If (e.Severity = Xml.Schema.XmlSeverityType.Warning) Then
        sMsgErr = "Avertissement lors de la validation du schéma : " 
    Else
        sMsgErr = "Erreur de validation du schéma : " 
    End If
    sMsgErr &= vbCrLf & "Ligne n°" & e.Exception.LineNumber & _
        ", position " & e.Exception.LinePosition & " : " & e.Message
    If Not m_bErr Then
        m_bErr = True
        If Not bVerifAppliDejaOuverte() Then MsgBox(sMsgErr, MsgBoxStyle.Critical, sTitreMsg)
    End If
    m_sbErr.Append(sMsgErr).Append(vbCrLf)

    Dim sMemErr$ = ""
    Dim sErr$ = "L" & e.Exception.LineNumber & "P" & e.Exception.LinePosition
    Dim sCle$ = e.Message
    If m_htTypesErr.ContainsKey(sCle) Then
        sMemErr = CStr(m_htTypesErr(sCle)) & ", "
    End If
    m_htTypesErr(sCle) = sMemErr & sErr

End Sub

#End Region

#Region "Normaliser la casse des balises xml en minuscules"

Private Function bNormaliser(ByVal sCheminXml$) As Boolean

    ' Normaliser la casse des balises xml en minuscules

    Dim xmlDoc As New XmlDocument
    m_xmlDoc = xmlDoc
    Try
        xmlDoc.Load(sCheminXml)
    Catch ex As Exception
        AfficherMsgErreur2(ex, "bNormaliser", "Fichier : " & sCheminXml)
        Exit Function
    End Try

    m_bSauverXml = False
    Dim iNiv% = 1
    m_sb = New StringBuilder
    For Each xmlNodeEnfant As XmlNode In xmlDoc.ChildNodes
        Dim sArboEnfant$ = xmlNodeEnfant.Name & "\"
        Normaliser_bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)
    Next

    Dim sFichier0$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
    Dim sChemin0$ = IO.Path.GetDirectoryName(sCheminXml)
    Dim sCheminXmlNorm$ = sChemin0 & "\" & _
        sFichier0 & sPostFixe_Normalise & ".xml"
    xmlDoc.Save(sCheminXmlNorm)

    bNormaliser = True

    If bVerifAppliDejaOuverte() Then Exit Function

    MsgBox("Une version normalisée du fichier xml a été générée !", _
        MsgBoxStyle.Exclamation, sTitreMsg)

End Function

Private Function Normaliser_bListerNoeudsEnfants(ByVal xmlNodeParent As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$) As Boolean

    If Not xmlNodeParent.HasChildNodes Then
        Exit Function
    End If

    Dim xmlNodeEnfant As XmlNode = Nothing
    For Each xmlNodeEnfant In xmlNodeParent.ChildNodes
        Normaliser_Noeud_Main(xmlNodeEnfant, iNiv, sArboParent)
    Next

    ' Il n'y a plus d'enfant suivant, à moins qu'un noeud ait été corrigé, attention !
    Dim xmlNodeEnfantReste As XmlNode = xmlNodeEnfant.NextSibling
ResteNoeuds:
    If Not IsNothing(xmlNodeEnfantReste) Then
        'Debug.WriteLine(iNiv & ":" & sArboParent & ":" & xmlNodeEnfantReste.Value)
        Normaliser_Noeud_Main(xmlNodeEnfantReste, iNiv, sArboParent)
        xmlNodeEnfantReste = xmlNodeEnfantReste.NextSibling
        GoTo ResteNoeuds
    End If

    Normaliser_bListerNoeudsEnfants = True

End Function

Private Sub Normaliser_Noeud_Main(ByRef xmlNodeEnfant As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$)

    ' Penser à mettre ByRef xmlNodeEnfant car le noeud peut être renommé

    Dim sNoeudEnfant$ = xmlNodeEnfant.Name

    Dim sArboEnfant$ = sArboParent & sNoeudEnfant & "\"
    Select Case sNoeudEnfant.ToLower
    Case sBaliseCommentaire : Exit Sub  ' Ignorer les commentaires
    Case sBaliseTexte : GoTo Suite
    Case sBaliseContenu.ToLower : GoTo Suite
    End Select

    Dim sNouvNom$ = sNoeudEnfant.ToLower ' Normaliser en minuscules
    If sNouvNom = sNoeudEnfant Then GoTo Suite
    RenommerNoeudXml(xmlNodeEnfant, sNouvNom, m_xmlDoc)

Suite:
    Normaliser_bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)

End Sub

#End Region

#Region "Utilitaires xml"

Private Function bIndenterXml(ByVal sCheminXml$) As Boolean

    ' Corriger la présentation Xml

    Dim xmlDoc As New XmlDocument
    m_xmlDoc = xmlDoc
    Try
        xmlDoc.Load(sCheminXml)
    Catch ex As Exception
        AfficherMsgErreur2(ex, "bIndenterXml", "Fichier : " & sCheminXml)
        Exit Function
    End Try

    'xmlDoc.PreserveWhitespace = False ' False : déjà l'option par défaut

    ' Solution 1 : simple réécriture avec PreserveWhitespace=False
    '  mais il reste des caractères non reconnus sous Windows : vbLf
    'xmlDoc.Save(sCheminXml) 

    ' Solution 2 : on peut modifier l'indentation, mais reste pb vbLf
    ' Certaines balises ne sont pas indentées correctement : 
    '  pas l'un en dessous de l'autre
    Dim sw As New IO.StringWriter()

    'Dim xtw As New XmlTextWriter(sw)
    'xtw.Formatting = Formatting.Indented
    'xtw.Indentation = 2

     ' Pour pouvoir modifier les settings, il faut utiliser le constructeur Create
    Dim settings As XmlWriterSettings = New XmlWriterSettings()
    settings.Indent = True
    ' Manque des sauts de ligne (pas systématique, dommage) mais mieux que rien
    settings.NewLineOnAttributes = True
    'settings.NewLineHandling =
    Dim xtw As XmlWriter = XmlWriter.Create(sw, settings)

    xmlDoc.WriteTo(xtw)
    xtw.Close()

    ' D'abord isoler les CrLf pour éviter de perdre les Lf
    Const sTmpCrLf$ = "__||__"
    Dim sb As New StringBuilder
    sb.Append(sw.ToString)
    sb.Replace(vbCrLf, sTmpCrLf)
    ' Ensuite supprimer les Lf
    sb.Replace(vbLf, "")
    ' Enfin rétablir les CrLf
    sb.Replace(sTmpCrLf, vbCrLf)

    ' Faire une copie de sauvegarde car parfois un encodage particulier 
    '  peut faire perdre le contenu
    Dim sCheminBak$ = IO.Path.GetDirectoryName(sCheminXml) & "\" & _
        IO.Path.GetFileNameWithoutExtension(sCheminXml) & ".bak"
    bCopierFichier(sCheminXml, sCheminBak)

    bEcrireFichier(sCheminXml, sb)

    bIndenterXml = True

    If bVerifAppliDejaOuverte() Then Exit Function

    MsgBox("La présentation du fichier xml a été corrigée !", _
        MsgBoxStyle.Exclamation, sTitreMsg)

End Function

Public Function bIgnorerDTD(ByRef sCheminXml$) As Boolean

    ' Ecrire une copie du fichier xml sans la DTD si elle est présente

    Dim bDTDPresente As Boolean = False
    Dim sb As New StringBuilder
    Dim iNumLigne% = 0
    Try
        Using fs As New IO.FileStream(sCheminXml, IO.FileMode.Open, IO.FileAccess.Read)
            Using sr As New IO.StreamReader(fs, _
                Encoding.GetEncoding(iCodePageWindowsLatin1252))
                Do
                    Dim sLigne$ = sr.ReadLine()
                    If IsNothing(sLigne) Then Exit Do
                    If sLigne.IndexOf("<!DOCTYPE") > -1 Then
                        ' Ne pas inclure la DTD
                        bDTDPresente = True
                    Else
                        sb.Append(sLigne).Append(vbCrLf)
                    End If
                    iNumLigne += 1
                    If iNumLigne = 3 And Not bDTDPresente Then Exit Do
                Loop While True
            End Using
        End Using
        If Not bDTDPresente Then
            bIgnorerDTD = True
            Exit Function
        End If
        Dim sCheminXmlSansDTD$ = IO.Path.GetDirectoryName(sCheminXml) & "\" & _
            IO.Path.GetFileNameWithoutExtension(sCheminXml) & _
            sPostFixe_SansDTD & IO.Path.GetExtension(sCheminXml)
        If Not bEcrireFichier(sCheminXmlSansDTD, sb) Then Exit Function
        sCheminXml = sCheminXmlSansDTD
        bIgnorerDTD = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bIgnorerDTD")
        Exit Function
    End Try

End Function

Public Sub RenommerNoeudXml(ByRef noeudOrig As XmlNode, ByVal sNouvNom$, _
    ByVal xmlDoc As XmlDocument)

    ' Renommer un noeud xml (en en créant un autre) d'après la src :
    ' http://www.csharpfr.com/infomsg_RENOMMER-BALISE-XML_834617.aspx
    ' Attention, à la fin on remplace le noeud d'origine par le nouveau :
    '  pensez à mettre ByRef XmlNode au lieu de ByVal
    '  et attention aussi aux énumérations :
    '   For Each xmlNodeEnfant In xmlNodeParent.ChildNodes :
    '  le noeaud modifié risque d'être manqué

    Dim noeudFinal As XmlNode = xmlDoc.CreateElement(sNouvNom)
    noeudFinal.InnerXml = noeudOrig.InnerXml
    For Each attribute As XmlAttribute In noeudOrig.Attributes
        Dim newAttribute As XmlAttribute = _
            DirectCast(attribute.Clone(), XmlAttribute)
        noeudFinal.Attributes.Append(newAttribute)
    Next
    noeudOrig.ParentNode.ReplaceChild(noeudFinal, noeudOrig)
    noeudOrig = noeudFinal

End Sub

#End Region

End Module


modXml2DTD.vb



Imports System.Xml
Imports System.Text ' Pour StringBuilder
Imports System.Collections.Specialized.CollectionsUtil ' Pour CreateCaseInsensitiveHashtable

Module Xml2DTD

Private Const bVerifierDoublons As Boolean = True
Private Const bDebugDTD As Boolean = True
Private Const bDebugDTD_Txt As Boolean = True

Private m_xmlDoc As XmlDocument
Private m_bGenererDTDNonDedoub As Boolean = False

Private m_htNoeuds As Hashtable
'Private m_htNoeuds As HashtableTri(Of clsNoeudXml)

Private m_lNbNoeuds&
Private m_htNoeudsXml As Hashtable
Private m_htNoeudsXmlRenommes As Hashtable
Private m_iCompteurDedoubl%
Private m_bSauverXml As Boolean
Private m_sb As StringBuilder

Private Const sSeparateurMiseAPlat$ = "__"

#Region "Extraction DTD"

Public Function bExtraireDTD(ByVal sCheminXml$, _
    ByVal bGenererDTDNonDedoub As Boolean) As Boolean

    m_bGenererDTDNonDedoub = bGenererDTDNonDedoub

    If Not bIgnorerDTD(sCheminXml) Then Exit Function

    Dim xmlDoc As New XmlDocument
    m_xmlDoc = xmlDoc

    Try
        ' Gestion des erreurs basiques : Xml non conforme, ou non conforme à sa 
        '  DTD si elle est précisée (mais vérification sommaire : incomplète)
        '  Vérification complète : cf. bVerifierXmlDTD
        xmlDoc.Load(sCheminXml)

    Catch ex As Exception
        AfficherMsgErreur2(ex, "bExtraireDTD", "Fichier : " & sCheminXml)
        Exit Function
    End Try

    Dim iNiv%
    If bVerifierDoublons Then
        ' D'abord vérifier si le xml doit être dédoublonné (sans hiérarchie)
        m_bSauverXml = False
        iNiv = 1
        m_sb = New StringBuilder
        m_htNoeudsXml = CreateCaseInsensitiveHashtable()
        m_htNoeudsXmlRenommes = CreateCaseInsensitiveHashtable()
        m_iCompteurDedoubl = 0
        For Each xmlNodeEnfant As XmlNode In xmlDoc.ChildNodes
            Dim sArboEnfant$ = xmlNodeEnfant.Name & "\"
            bListerNoeudsEnfants0(xmlNodeEnfant, iNiv + 1, sArboEnfant)
        Next

        If m_bSauverXml Then
            Dim sFichier0$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
            Dim sChemin0$ = IO.Path.GetDirectoryName(sCheminXml)
            If bDebugDTD_Txt Then
                Dim sCheminDTDTxt0$ = sChemin0 & "\" & sFichier0 & ".txt"
                If Not bEcrireFichier(sCheminDTDTxt0, m_sb) Then Exit Function
                If Not bVerifAppliDejaOuverte() Then
                    ProposerOuvrirFichier(sCheminDTDTxt0)
                End If
            End If
            Dim sCheminXmlDedoub$ = sChemin0 & "\" & _
                sFichier0 & sPostFixe_Dedoub & ".xml"
            'xmlDoc.PreserveWhitespace = True
            xmlDoc.Save(sCheminXmlDedoub)

            bExtraireDTD = True

            If bVerifAppliDejaOuverte() Then Exit Function

            MsgBox("Le fichier xml est hiérarchique, une version plate a été générée !", _
                MsgBoxStyle.Exclamation, sTitreMsg)

            Exit Function

        End If
    End If

    ' Les noeuds enfants doivent être triés, mais pas réussi à utiliser
    '  à la fois CaseInsensitive et htTri, donc simple ht pour m_htNoeuds 
    'm_htNoeuds = CreateCaseInsensitiveHashtable()
    m_htNoeuds = New Hashtable 'HashtableTri(Of clsNoeudXml)
    m_sb = New StringBuilder
    m_lNbNoeuds = 0

    iNiv = 1
    Dim sCleRacine$ = ""
    Dim bCleRacine As Boolean = False

    Dim sArboParent$ = "\"
    For Each xmlNodeEnfant As XmlNode In xmlDoc.ChildNodes

        Dim sArboEnfant$ = xmlNodeEnfant.Name & "\"
        IndexerNoeud(iNiv, xmlNodeEnfant.Name, sArboEnfant, sArboParent)
        If bDebugDTD Then
            Dim Idx As clsNoeudXml = DirectCast(m_htNoeuds(sArboEnfant), clsNoeudXml)
            m_sb.Append(xmlNodeEnfant.Name & " (" & _
                Idx.lNbNoeuds & ")" & vbCrLf)
        End If

        bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)
        If Not bCleRacine Then
            If sArboEnfant.ToLower <> "xml\" Then
                bCleRacine = True
                sCleRacine = sArboEnfant
            End If
        End If
    Next

    Dim iNbLignes% = m_htNoeuds.Count
    Dim aIdx() As clsNoeudXml = Nothing
    If bDebugDTD_Txt Then
        ReDim aIdx(iNbLignes - 1)
    End If

    Dim iNumLigne% = 0
    Dim de As IDictionaryEnumerator = m_htNoeuds.GetEnumerator
    While de.MoveNext()
        Dim sCleEnfant$ = de.Key.ToString
        Dim IdxEnfant As clsNoeudXml = DirectCast(m_htNoeuds(sCleEnfant), clsNoeudXml)

        ' Remplir les noeuds enfants des noeuds parents
        Dim sCleParent$ = IdxEnfant.sArboParent
        If m_htNoeuds.ContainsKey(sCleParent) Then
            Dim IdxParent As clsNoeudXml = DirectCast(m_htNoeuds(sCleParent), clsNoeudXml)
            If Not IdxParent.htNoeudsEnfants.ContainsKey(sCleEnfant) Then
                IdxParent.htNoeudsEnfants.Add(sCleEnfant, IdxEnfant)
                If IdxParent.htNoeudsEnfants.Count > IdxParent.lNbNoeudsMax Then
                    'If IdxParent.sNoeud = "template" Then
                    '    Debug.WriteLine(IdxParent.sNoeud & " : " & IdxEnfant.sNoeud)
                    'End If
                    IdxParent.lNbNoeudsMax = IdxParent.htNoeudsEnfants.Count
                End If
            End If
        End If

        If Not bDebugDTD_Txt Then Continue While
        ' Trier les noeuds via un tableau
        aIdx(iNumLigne) = IdxEnfant
        iNumLigne += 1

    End While

    ' Seconde passe : noeuds min
    de.Reset()
    While de.MoveNext()
        Dim sCleEnfant$ = de.Key.ToString
        Dim ne As clsNoeudXml = DirectCast(m_htNoeuds(sCleEnfant), clsNoeudXml)
        Dim iNbNoeudsEnfants% = ne.htNoeudsEnfants.Count
        If iNbNoeudsEnfants < ne.lNbNoeudsMin Then
            ne.lNbNoeudsMin = iNbNoeudsEnfants
        End If

        ' Voir si le parent recense + d'enfant
        If ne.iNiv > 1 AndAlso ne.sArboParent.Length > 0 Then
            Dim np As clsNoeudXml = DirectCast(m_htNoeuds(ne.sArboParent), clsNoeudXml)
            Dim lNbNoeudsEnfants& = np.lNbNoeuds
            If lNbNoeudsEnfants > ne.lNbNoeuds Then
                ' Au quel cas le noeud enfant peut être absent
                ne.lNbNoeudsMin = 0
            End If
        End If

    End While

    If Not bDebugDTD_Txt Then GoTo Suite
    If bDebugDTD_Txt Then m_sb.Append(vbCrLf & vbCrLf)
    TrierArbo(aIdx, "sArbo", "Index trié par ordre alphabétique :")
    TrierArbo(aIdx, "lNbNoeuds DESC, sArbo", "Index trié par fréquence décroissante :")

Suite:
    Dim sb As New StringBuilder()
    If Not m_htNoeuds.ContainsKey(sCleRacine) Then
        'Debug.WriteLine("!")
        If bDebug Then Stop
        Exit Function
    End If
    Dim IdxRacine As clsNoeudXml = DirectCast(m_htNoeuds(sCleRacine), clsNoeudXml)
    ListerNoeudsEnfantsHt(IdxRacine, sb)

    Dim sFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminXml)
    Dim sChemin$ = IO.Path.GetDirectoryName(sCheminXml)
    Dim sCheminDTD$ = sChemin & "\" & sFichier & ".dtd"
    If Not bEcrireFichier(sCheminDTD, sb) Then Exit Function

    If bDebugDTD_Txt Or bDebugDTD Then
        Dim sCheminDTDTxt$ = sChemin & "\" & sFichier & ".txt"
        If Not bEcrireFichier(sCheminDTDTxt, m_sb) Then Exit Function
    End If

    bExtraireDTD = True

    If bVerifAppliDejaOuverte() Then Exit Function

    ProposerOuvrirFichier(sCheminDTD)

End Function

Private Function bListerNoeudsEnfants0(ByVal xmlNodeParent As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$) As Boolean

    If Not xmlNodeParent.HasChildNodes Then
        Exit Function
    End If

    Dim xmlNodeEnfant As XmlNode = Nothing
    For Each xmlNodeEnfant In xmlNodeParent.ChildNodes
        VerifierNoeudXml(xmlNodeEnfant, iNiv, sArboParent)
    Next

    ' Il n'y a plus d'enfant suivant, à moins qu'un noeud ait été renommé, attention !
    Dim xmlNodeEnfantReste As XmlNode = xmlNodeEnfant.NextSibling
ResteNoeuds:
    If Not IsNothing(xmlNodeEnfantReste) Then
        'Debug.WriteLine(iNiv & ":" & sArboParent & ":" & xmlNodeEnfantReste.Value)
        VerifierNoeudXml(xmlNodeEnfantReste, iNiv, sArboParent)
        xmlNodeEnfantReste = xmlNodeEnfantReste.NextSibling
        GoTo ResteNoeuds
    End If

    bListerNoeudsEnfants0 = True

End Function

Private Sub VerifierNoeudXml(ByRef xmlNodeEnfant As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$)

    ' Penser à mettre ByRef xmlNodeEnfant car le noeud peut être renommé

    Dim sNoeudEnfant$ = xmlNodeEnfant.Name

    'If sNoeudEnfant = "person" Then
        'Debug.WriteLine(iNiv & ":" & sArboParent & ":" & xmlNodeEnfant.Value)
    'End If

    Dim sArboEnfant$ = sArboParent & sNoeudEnfant & "\"
    Select Case sNoeudEnfant.ToLower
    Case sBaliseCommentaire : Exit Sub  ' Ignorer les commentaires
    Case sBaliseTexte : GoTo Suite
    Case sBaliseDonnees : GoTo Suite
    Case sBaliseContenu.ToLower : GoTo Suite
    End Select

    Dim sNoeudEnfantDedoubl$ = sNoeudEnfant
    Dim sDoublon$ = ""
    If m_htNoeudsXml.ContainsKey(sNoeudEnfant) Then
        Dim sArboEnfant0$ = CStr(m_htNoeudsXml(sNoeudEnfant))
        If sArboEnfant0.ToLower <> sArboEnfant.ToLower Then

            ' L'arborescence ne correspond pas : c'est un doublon

            ' 1ère solution pour dédoublonner : utiliser l'arbo. en guise de noeud
            '  bien mais pas très lisible
            'sNoeudEnfantDedoubl = sArboEnfant.Replace("\", "_")
            'If sNoeudEnfantDedoubl.EndsWith("_") Then
            '    sNoeudEnfantDedoubl = sNoeudEnfantDedoubl.Substring(0, _
            '        sNoeudEnfantDedoubl.Length - 1)
            'End If

            ' 2ème solution : compteur de dédoublonnage
            ' 2a : compteur global pour commencer
            If Not m_htNoeudsXmlRenommes.ContainsKey(sArboEnfant) Then
                ' Première occurence : incrémenter le compteur et ajouter le nouv. nom
                m_iCompteurDedoubl += 1
                ' Ajouter un _ au cas où le nom du noeud finirait déjà par un chiffre 
                ' (ex.: person2)
                sNoeudEnfantDedoubl = sNoeudEnfant & sSeparateurMiseAPlat & m_iCompteurDedoubl
                m_htNoeudsXmlRenommes.Add(sArboEnfant, sNoeudEnfantDedoubl)
            Else
                sNoeudEnfantDedoubl = CStr(m_htNoeudsXmlRenommes(sArboEnfant))
            End If

            RenommerNoeudXml(xmlNodeEnfant, sNoeudEnfantDedoubl, m_xmlDoc)
            m_bSauverXml = True

            If bDebugDTD_Txt Then
                If bDebug Then Debug.WriteLine(iNiv & ":" & _
                    sArboParent & ":" & xmlNodeEnfant.Value)
                sDoublon = " <> " & sArboEnfant0 & " -> " & sNoeudEnfantDedoubl
                Dim n1 As XmlNode = xmlNodeEnfant.NextSibling
                If Not IsNothing(n1) Then sDoublon &= " (" & n1.InnerText.Trim & ")"
                m_sb.Append(sArboEnfant & sDoublon & vbCrLf)
            End If

        End If
    Else
        m_htNoeudsXml.Add(sNoeudEnfant, sArboEnfant)
    End If

    'If bDebugDTD_Txt Then
    '    Dim sEspaces$ = Space((iNiv - 1) * 4)
    '    Dim sPresentation$ = sEspaces
    '    m_sb.Append(sPresentation & sNoeudEnfantDedoubl & sDoublon & vbCrLf)
    'End If

Suite:
    bListerNoeudsEnfants0(xmlNodeEnfant, iNiv + 1, sArboEnfant)

End Sub

Private Sub TrierArbo(ByVal aIdx() As clsNoeudXml, ByVal sTri$, ByVal sTitre$)

    ' Tri des lignes
    Dim comp As New UniversalComparer(Of clsNoeudXml)(sTri)
    Array.Sort(Of clsNoeudXml)(aIdx, comp)

    m_sb.Append(sTitre & vbCrLf & vbCrLf)
    For Each Idx As clsNoeudXml In aIdx
        Dim rPC! = CSng(Idx.lNbNoeuds / m_lNbNoeuds)
        Dim sPC$ = rPC.ToString("0.00%")
        m_sb.Append(Idx.sArbo & " : " & sPC & _
            " (" & Idx.lNbNoeuds & ", " & Idx.lNbNoeudsMin & ", " & _
                   Idx.lNbNoeudsMax & ")").Append(vbCrLf)
    Next
    m_sb.Append(vbCrLf & vbCrLf)

End Sub

Private Sub ListerNoeudsEnfantsHt(ByVal IdxParent As clsNoeudXml, _
    ByVal sb As StringBuilder)

    Dim iNiv1% = IdxParent.iNiv
    Dim sEspaces1$ = Space((iNiv1 - 1) * 4)
    ' Ne pas mettre d'espace entre < et !ELEMENT
    Dim sNoeud0$ = IdxParent.sNoeud
    Dim sbPresentationEnfants As New StringBuilder
    If m_bGenererDTDNonDedoub Then
        sbPresentationEnfants.Append(vbCrLf & Space(iNiv1 * 4 + 2))
        Dim iPos0% = sNoeud0.IndexOf(sSeparateurMiseAPlat)
        If iPos0 > 0 Then
            sNoeud0 = sNoeud0.Substring(0, iPos0)
        End If
    End If
    Dim sPresentation1$ = sEspaces1 & "<!ELEMENT " & sNoeud0
    sb.Append(sPresentation1)

    Dim bPasse2 As Boolean = False
    Dim bBaliseDTDContenuPresente As Boolean = False

Recommencer:
    Dim sbTmp As New StringBuilder
    Dim iNumEnfant% = 0
    Dim iNbEnfants% = IdxParent.htNoeudsEnfants.Count
    Dim sSignalCompteurGroupe$ = ""

    For Each IdxEnfant As clsNoeudXml In IdxParent.htNoeudsEnfants.Trier("sNoeud")

        ' S'il y a une balise #PCData, elle doit être en position 1
        iNumEnfant += 1
        If Not bBaliseDTDContenuPresente AndAlso _
           (iNumEnfant > 1 And IdxEnfant.sNoeud.ToLower = sBaliseContenu.ToLower) Then
            bBaliseDTDContenuPresente = True
            Exit For
        End If

        'Dim iNiv0% = IdxEnfant.iNiv
        If iNumEnfant = 1 Then sbTmp.Append(" ( ")

        If bBaliseDTDContenuPresente And bPasse2 And iNumEnfant = 1 Then
            sbTmp.Append("#PCDATA | ")
        End If
        If iNumEnfant > 1 Then
            ' Pour le moment : liste -> * : on ne regarde pas 
            '  les noeuds enfants oblig. ou pas
            sSignalCompteurGroupe = "*"
        End If

        ' Pour les fils uniques, voir si le fils unique peut être absent,
        '  auquel cas il faut mettre * pour indiquer la possibilité d'absence
        ' Attention : en fait iNumEnfant est le n°, il peut continuer à augmenter
        '  mais ok ici (juste en passe 2, mais pas possible d'imposer Passe 2 car pas tjrs)
        'If iNumEnfant = 1 And _
        '   IdxEnfant.lNbNoeudsMin = 0 And IdxEnfant.lNbNoeudsMax = 0 And _
        '   IdxParent.lNbNoeudsMin = 0 And IdxParent.lNbNoeudsMax >= 1 AndAlso _
        '   IdxEnfant.sNoeud.ToLower <> sBaliseContenu.ToLower Then

        ' Version + souple mais + simple aussi : ajoute des *, mais tjrs ok
        ' Pour les fils uniques, voir si le fils unique peut être absent,
        '  auquel cas il faut mettre * pour indiquer la possibilité d'absence
        ' Même solution pour max > 1 : tout le groupe à *
        If (IdxEnfant.lNbNoeudsMin = 0 Or IdxEnfant.lNbNoeudsMax > 1) AndAlso _
           IdxEnfant.sNoeud.ToLower <> sBaliseContenu.ToLower Then
           sSignalCompteurGroupe = "*"
           'Debug.WriteLine(String.Format( _
           '     "Fil unique optionel : {0} : Min : {1} Max : {2} : Parent : {3}, NbFrères : {4}, MinP : {5} MaxP : {6}", _
           '     IdxEnfant.sNoeud, _
           '     IdxEnfant.lNbNoeudsMin, IdxEnfant.lNbNoeudsMax, _
           '     IdxParent.sNoeud, iNumEnfant, _
           '     IdxParent.lNbNoeudsMin, IdxParent.lNbNoeudsMax))
        End If

        If bBaliseDTDContenuPresente And bPasse2 And _
            IdxEnfant.sNoeud.ToLower = sBaliseContenu.ToLower Then
            Continue For
        End If

        If iNumEnfant > 1 Then
            sbTmp.Append(" | ")
            sbTmp.Append(sbPresentationEnfants)
        End If

        Dim sNoeud$ = IdxEnfant.sNoeud
        If m_bGenererDTDNonDedoub Then
            Dim iPos% = sNoeud.IndexOf(sSeparateurMiseAPlat)
            If iPos > 0 Then
                sNoeud = sNoeud.Substring(0, iPos)
            End If
        End If
        sbTmp.Append(sNoeud)

        'Dim sSignalCompteur$ = ""
        'If IdxEnfant.lNbNoeudsMax = 0 Then
        '    'sSignalCompteur = ""
        'ElseIf IdxEnfant.lNbNoeudsMin = 0 And IdxEnfant.lNbNoeudsMax = 1 Then
        '    'sSignalCompteur = "?" ' Ne marche pas !
        'ElseIf IdxEnfant.lNbNoeudsMin = 0 And IdxEnfant.lNbNoeudsMax > 1 Then
        '    ' Ne marche pas toujours : on ne peut mélanger des types avec ou sans *
        '    'sSignalCompteur = "*" 
        'ElseIf IdxEnfant.lNbNoeudsMin = 1 And IdxEnfant.lNbNoeudsMax = 1 Then
        '    'sSignalCompteur = ""
        'ElseIf IdxEnfant.lNbNoeudsMin >= 1 And IdxEnfant.lNbNoeudsMax > 1 _
        '    And IdxParent.lNbNoeudsMin <= 1 And IdxParent.lNbNoeudsMax = 1 Then
        '    ' Les modèles de contenu mixte ne peuvent pas contenir de 
        '    '  contraintes d'occurrence individuelle sur ses membres.
        '    ' -> Solution : en fait on peut qd même utiliser + à condition que
        '    '    l'élément n'aie pas de frère : aiml ( category+ ) ou random ( li+ )
        '    ' mais compter le nombre de types <> min. et max. TODO
        '    ' Test ok pour le moment : parent min max = 1 -> seul srai+ bizarre mais DTD ok
        '    'sSignalCompteur = "+" ' Ne marche pas !
        '    'Debug.WriteLine(String.Format( _
        '    '    "Noeud {0} : Min : {1} Max : {2} : Parent : {3}, NbFrères : {4}, MinP : {5} MaxP : {6}", _
        '    '    IdxEnfant.sNoeud, _
        '    '    IdxEnfant.lNbNoeudsMin, IdxEnfant.lNbNoeudsMax, _
        '    '    IdxParent.sNoeud, iNumEnfant, _
        '    '    IdxParent.lNbNoeudsMin, IdxParent.lNbNoeudsMax))
        '    sSignalCompteur = "+"
        'ElseIf IdxEnfant.lNbNoeudsMax > 1 Then
        '    'sSignalCompteur = "*" ' Ne marche pas !
        'End If
        'If sSignalCompteur.Length > 0 Then sbTmp.Append(sSignalCompteur)

        'Debug.WriteLine(String.Format( _
        '        "Noeud {0} : Min : {1} Max : {2} : Parent : {3}, NbFrères : {4}, MinP : {5} MaxP : {6}", _
        '        IdxEnfant.sNoeud, _
        '        IdxEnfant.lNbNoeudsMin, IdxEnfant.lNbNoeudsMax, _
        '        IdxParent.sNoeud, iNumEnfant, _
        '        IdxParent.lNbNoeudsMin, IdxParent.lNbNoeudsMax))

    Next

    If bBaliseDTDContenuPresente And Not bPasse2 Then
        bPasse2 = True
        GoTo Recommencer
    End If

    sb.Append(sbTmp)

    If iNumEnfant > 0 Then
        sb.Append(" )" & sSignalCompteurGroupe)
    Else
        sb.Append(" EMPTY")
    End If
    sb.Append(">" & vbCrLf)

    For Each IdxEnfant As clsNoeudXml In IdxParent.htNoeudsEnfants.Trier("sNoeud")
        If IdxEnfant.sNoeud.ToLower = sBaliseContenu.ToLower Then Continue For
        ListerNoeudsEnfantsHt(IdxEnfant, sb)
    Next

End Sub

Private Function bListerNoeudsEnfants(ByVal xmlNodeParent As XmlNode, _
    ByVal iNiv%, ByVal sArboParent$) As Boolean

    If Not xmlNodeParent.HasChildNodes Then
        Exit Function
    End If

    ' Voir si un noeud enfant peut être présent plusieurs fois
    '  dans la même instance du noeud parent
    Dim htNoeudsEnfants As Hashtable = CreateCaseInsensitiveHashtable()
    For Each xmlNodeEnfant As XmlNode In xmlNodeParent.ChildNodes

        Dim sNoeudEnfant$ = xmlNodeEnfant.Name

        'If sNoeudEnfant = "person" Then
        '    Debug.WriteLine(iNiv & ":" & sArboParent)
        'End If

        Select Case sNoeudEnfant.ToLower
        Case sBaliseCommentaire : Continue For ' Ignorer les commentaires
        Case sBaliseTexte : sNoeudEnfant = sBaliseContenu
        Case sBaliseDonnees : sNoeudEnfant = sBaliseContenu
        End Select

        ' Indexation des noeuds
        Dim sArboEnfant$ = sArboParent & sNoeudEnfant & "\"
        IndexerNoeud(iNiv, sNoeudEnfant, sArboEnfant, sArboParent)

        If htNoeudsEnfants.ContainsKey(sNoeudEnfant) Then

            Dim np As clsNoeudXml = DirectCast(m_htNoeuds(sArboParent), clsNoeudXml)

            ' Compter le nombre possible d'enfants de chaque type
            Dim ne As clsNoeudXml = DirectCast(htNoeudsEnfants(sNoeudEnfant), clsNoeudXml)
            ne.lNbNoeuds += 1

            ' Mettre à jour les infos du noeud sur la hashtable globale maintenant
            Dim neg As clsNoeudXml = DirectCast(m_htNoeuds(sArboEnfant), clsNoeudXml)
            If ne.lNbNoeuds > neg.lNbNoeudsMax Then
                'Debug.WriteLine(neg.sNoeud)
                neg.lNbNoeudsMax = ne.lNbNoeuds
            End If

        Else

            ' D'abord on comptabilise les noeuds enfants seulement au niveau de chaque instance
            '  et lors d'une seconde passe, on comptabilisera au niveau global

            Dim ne As New clsNoeudXml
            ne.lNbNoeuds = 1
            ne.lNbNoeudsMin = 1
            ne.lNbNoeudsMax = 1
            ne.sArbo = sArboEnfant
            ne.sArboParent = sArboParent
            ne.iNiv = iNiv
            ne.sCle = sNoeudEnfant
            htNoeudsEnfants.Add(sNoeudEnfant, ne)

        End If

        If bDebugDTD Then
            Dim sEspaces$ = Space((iNiv - 1) * 4)
            Dim sPresentation$ = sEspaces
            Dim Idx As clsNoeudXml = DirectCast(m_htNoeuds(sArboEnfant), clsNoeudXml)
            m_sb.Append(sPresentation & sNoeudEnfant & " (" & _
                Idx.lNbNoeuds & ")" & vbCrLf)
        End If

        bListerNoeudsEnfants(xmlNodeEnfant, iNiv + 1, sArboEnfant)

    Next

    bListerNoeudsEnfants = True

End Function

Private Sub IndexerNoeud(ByVal iNiv%, ByVal sNoeud$, _
    ByVal sArboEnfant$, ByVal sArboParent$)

    ' Indexer les noeuds

    m_lNbNoeuds += 1

    Dim sCle$ = sArboEnfant
    Dim idx As clsNoeudXml
    If m_htNoeuds.ContainsKey(sCle) Then
        idx = DirectCast(m_htNoeuds(sCle), clsNoeudXml)
        idx.lNbNoeuds += 1
        Exit Sub
    End If

    idx = New clsNoeudXml
    idx.iNiv = iNiv
    idx.sCle = sCle
    idx.sNoeud = sNoeud
    idx.sArbo = sArboEnfant
    idx.sArboParent = sArboParent
    idx.lNbNoeuds = 1
    idx.lNbNoeudsMin = Long.MaxValue
    'idx.htNoeudsEnfants = CreateCaseInsensitiveHashtable()
    idx.htNoeudsEnfants = New HashtableTri(Of clsNoeudXml)
    m_htNoeuds.Add(sCle, idx)

End Sub

#End Region

End Module


clsNoeudXml.vb



Public Class clsNoeudXml
    Public sCle$, sNoeud$, sArbo$, sArboParent$
    Public iNiv%

    ' Cumul des occurences globales toutes instances confondues
    Public lNbNoeuds&

    ' Nombre min. et max. de noeuds toutes instances confondues
    Public lNbNoeudsMin&, lNbNoeudsMax&

    Public htNoeudsEnfants As HashtableTri(Of clsNoeudXml)

End Class


clsHTTri.vb



' Classe hashtable triable

Public Class HashtableTri(Of T) : Inherits Hashtable

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


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

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


modUtil.vb



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

Module modUtil

Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _
    Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _
    Optional ByVal sDetailMsgErr$ = "", _
    Optional ByVal bCopierMsgPressePapier As Boolean = True, _
    Optional ByRef sMsgErrFinal$ = "")

    If Not Cursor.Current.Equals(Cursors.Default) Then _
        Cursor.Current = Cursors.Default
    Dim sMsg$ = ""
    If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct
    If sInfo <> "" Then sMsg &= vbCrLf & sInfo
    If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr
    If Ex.Message <> "" Then
        sMsg &= vbCrLf & Ex.Message.Trim
        If Not IsNothing(Ex.InnerException) Then _
            sMsg &= vbCrLf & Ex.InnerException.Message
    End If
    If bCopierMsgPressePapier Then CopierPressePapier(sMsg)
    sMsgErrFinal = sMsg
    MsgBox(sMsg, MsgBoxStyle.Critical)

End Sub

Public Sub Sablier(Optional ByRef bDesactiver As Boolean = False)

    If bDesactiver Then
        Cursor.Current = Cursors.Default
    Else
        Cursor.Current = Cursors.WaitCursor
    End If

End Sub

Public Sub CopierPressePapier(ByVal sInfo$)

    ' Copier des informations dans le presse-papier de Windows
    ' (elles resteront jusqu'à ce que l'application soit fermée)

    Try
        Dim dataObj As New DataObject
        dataObj.SetData(DataFormats.Text, sInfo)
        Clipboard.SetDataObject(dataObj)
    Catch ex As Exception
        ' Le presse-papier peut être indisponible
        AfficherMsgErreur2(ex, "CopierPressePapier", _
            bCopierMsgPressePapier:=False)
    End Try

End Sub

Public Sub TraiterMsgSysteme_DoEvents()

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

End Sub

Public Function bAppliDejaOuverte( _
    Optional ByVal bMemeExe As Boolean = True) As Boolean

    ' Détecter si l'application est déja lancée :
    ' - depuis n'importe quelle copie de l'exécutable
    '   (bMemeExe = Faux : tjrs une seule instance), ou bien seulement :
    ' - depuis le même emplacement du fichier exécutable sur le disque dur 
    '   (bMemeExe = Vrai par défaut : une seule instance au même endroit
    '    mais plusieurs instances possibles si les chemins sont distincts)

    Dim sExeProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.ModuleName
    Dim sNomProcessAct$ = IO.Path.GetFileNameWithoutExtension(sExeProcessAct)

    If Not bMemeExe Then
        ' Détecter si l'application est déja lancée depuis n'importe quel exe
        If Process.GetProcessesByName(sNomProcessAct).Length > 1 Then _
            bAppliDejaOuverte = True
        Exit Function
    End If

    ' Détecter si l'application est déja lancée depuis le même exe
    Dim sCheminProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.FileName
    Dim aProcessAct As Diagnostics.Process() = Process.GetProcessesByName(sNomProcessAct)
    Dim processAct As Diagnostics.Process
    Dim iNbApplis% = 0
    For Each processAct In aProcessAct
        Dim sCheminExe$ = processAct.MainModule.FileName
        If sCheminExe = sCheminProcessAct Then
            iNbApplis += 1
            If iNbApplis > 1 Then bAppliDejaOuverte = True : Exit For
        End If
    Next

End Function

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


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 sCheminFichier.Length > 0 Then .FileName = sCheminFichier ' 14/10/2007
        .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 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 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) As Boolean

    ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple)
    If Not bFichierExiste(sCheminFichier, bPrompt) Then
        ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas
        If bInexistOk Then bFichierAccessible = True
        Exit Function
    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 !
            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)
            'reponse = MsgBox("Veuillez fermer le fichier :" & vbLf & _
            '    sCheminFichier & vbLf & _
            '    "(le fichier n'est pas accessible en écriture)" & sQuestion, _
            '    msgbs, sTitreMsg)
        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)

    ' 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:=False) & " Go"
        ElseIf rNbMo >= 1 Then
            sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0:=False) & " Mo"
        ElseIf rNbKo >= 1 Then
            sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0:=False) & " 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

#End Region

#Region "Gestion des dossiers"

Public Function bVerifierCreerDossier(ByRef 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 ?)

    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
    ' 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)

    Dim Files$()
    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

    Files = IO.Directory.GetFileSystemEntries(sSrc)
    Dim Element$
    For Each Element In Files
        Dim sFichier$ = IO.Path.GetFileName(Element)
        If IO.Directory.Exists(Element) Then
            ' L'élement est un sous-dossier : le copier
            bCopierArbo(Element, sDest & sFichier, bStatut, sListeErr, sListeErrExcep)
        Else
            ' Sinon copier le fichier
            Try
                IO.File.Copy(Element, sDest & sFichier, True)
            Catch ex As Exception
                'Dim sFichier$ = IO.Path.GetFileName(Element).ToLower
                If sListeErrExcep.IndexOf(" " & sFichier & " ") = -1 Then
                    ' Noter le chemin du fichier imposs à copier ssi pas exception
                    If sListeErr.Length < 200 Then
                        If sListeErr = "" Then
                            sListeErr = sDest & sFichier
                        Else
                            sListeErr &= vbLf & sDest & sFichier
                        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
        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 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$) 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
        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 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 False = 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