VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFileConvert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"FileSrc"
Attribute VB_Ext_KEY = "Member1" ,"FileDest"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'--- propriétés publiques de la classe
Public PathFile_Src As String
Public PathFile_Dest As String
Public TypeFile_Src As TypeFichier
Public TypeFile_Dest As TypeFichier
Public OverWriteDest As Boolean
Public FirstLigneAsChamps As Boolean
Public FieldSeparator As String

'--- propriétés privées de la classe
Private TmpProgression As Integer
Private TmpRapport As String
Public Enum TypeFichier
    Access = 0
    Excel = 1
    Texte = 2
End Enum

Public toto
Private TableauSrc()
'--- TableauSrc(0)(0) == "NOM DELA TABLE"
'--- TableauSrc(0)(1)(0)= "TABLE 0 ,Nom du champ 0"
'--- TableauSrc(0)(1)(1)= "TABLE 0 ,Nom du champ 1"
'--- TableauSrc(0)(2) = "TABLE 0 ,Valeurs de la table"

Public Property Get ProgressionClasse() As String
'--- permet de récupérer une valeur indiquant l'état de la classe
        ProgressionClasse = TmpProgression
End Property
Public Property Get RapportClasse() As String
'---   Permet de récupérer l'état de la classe
    If TmpRapport <> "" Then
        RapportClasse = TmpRapport
        TmpRapport = ""
    End If
End Property
Public Function VerifIntegrite()
'--- vérifie l'intégrité des données
'---        Toutes les tables portent un nom différent
'---        Les noms des champs sont définis
'---        Tous les champs portent un nom différent
    Dim NumTable As Integer, NumTableVerif As Integer
    Dim NumChamp As Integer, NumChampVerif As Integer
    Dim NumRec As Integer, NbreChpMax As Integer
    Dim IndexInc As Integer
    Dim TabChamps As Variant, TabRec As Variant
'--- on vérifie que chaque table porte un nom unique
    For NumTable = 0 To UBound(TableauSrc, 1)
        DoEvents
        IndexInc = 1
        For NumTableVerif = NumTable To UBound(TableauSrc, 1)
            DoEvents
            If UCase(TableauSrc(NumTable)(0)) = UCase(TableauSrc(NumTableVerif)(0)) And NumTable <> NumTableVerif Then
            '--- si ce n'est pas le cas, on rajoute un suffixe numérique
                TableauSrc(NumTableVerif)(0) = TableauSrc(NumTableVerif)(0) & IndexInc
Call EtatClasse("Le groupe '" & TableauSrc(NumTable)(0) & "' est renomé en '" & TableauSrc(NumTableVerif)(0) & "'", 1)
                IndexInc = IndexInc + 1
            End If
        Next
    Next
'--- Verification des champs
    For NumTable = 0 To UBound(TableauSrc, 1)
        If UBound(TableauSrc(NumTable)(1)) = -1 Then
    '--- il n'y avait pas de noms de champs ... c la merde !!
'--- bon, c parti : on va lire les enregistrements de cette table et splitter les valeurs en stockant le nombre max de champs et créer les champs en fonction
        '--- strTmp = tableau des enregistrements
            NbreChpMax = 0
            TabRec = Split(TableauSrc(NumTable)(2), vbCrLf)
            For NumRec = 0 To UBound(TabRec)
                If UBound(Split(TabRec(NumRec), FieldSeparator)) - 1 > NbreChpMax Then
                    NbreChpMax = UBound(Split(TabRec(NumRec), FieldSeparator)) - 1
                End If
            Next
            IndexInc = 0
            TabChamps = ""
            For NumChamp = 0 To NbreChpMax
                TabChamps = TabChamps & "Champ" & IndexInc & FieldSeparator
                IndexInc = IndexInc + 1
            Next
            TabChamps = Left(TabChamps, Len(TabChamps) - 1)
            TableauSrc(NumTable)(1) = Split(TabChamps, FieldSeparator)
        Else
'--- il y a des noms de champs.on vérifie
            For NumChamp = 0 To UBound(TableauSrc(NumTable)(1))
                DoEvents
                IndexInc = 1
            'Remplace certains caractères ...
                TableauSrc(NumTable)(1)(NumChamp) = Replace(TableauSrc(NumTable)(1)(NumChamp), "#", "_")
                TableauSrc(NumTable)(1)(NumChamp) = Replace(TableauSrc(NumTable)(1)(NumChamp), ".", "_")
                TableauSrc(NumTable)(1)(NumChamp) = Replace(TableauSrc(NumTable)(1)(NumChamp), Chr(34), "")
                For NumChampVerif = NumChamp To UBound(TableauSrc(NumTable)(1))
                    DoEvents
                    If UCase(TableauSrc(NumTable)(1)(NumChamp)) = UCase(TableauSrc(NumTable)(1)(NumChampVerif)) And NumChamp <> NumChampVerif And TableauSrc(NumTable)(1)(NumChamp) <> "" Then
                    '--- si ce n'est pas le cas, on rajoute un suffixe numérique
                        TableauSrc(NumTable)(1)(NumChampVerif) = TableauSrc(NumTable)(1)(NumChampVerif) & IndexInc
            Call EtatClasse("Le champ '" & TableauSrc(NumTable)(1)(NumChamp) & "' est renomé en '" & TableauSrc(NumTable)(1)(NumChampVerif) & "'", 1)
                        IndexInc = IndexInc + 1
                    End If
                Next
            Next
        End If
    Next
End Function
Public Function Convert() As Boolean
'--- methode qui va lancer la procédure de conversion du fichier source en un fichier de destination
'---    Lecture du fichier source
'---    Application des contraintes du fichier source
'---    Ecriture du fichier de destination
    DoEvents
    Convert = False
    If LectFileSrc = True Then
        DoEvents
        Call VerifIntegrite
        If EcritFileDest = True Then
            DoEvents
            Call EtatClasse("CONVERSION DU FICHIER EFFECTUEE")
            Convert = True
        Else
            Call AlerteClasse("ECRITURE DU FICHIER SOURCE", "Une erreur est survenue pendant l'ecriture du fichier source !" & vbCrLf & "Le traitement doit s'arrêter")
        End If
    Else
        Call AlerteClasse("LECTURE DU FICHIER SOURCE", "Une erreur est survenue pendant la lecture du fichier source !" & vbCrLf & "Le traitement doit s'arrêter")
    End If
End Function
Private Function EcritFileDest() As Boolean
    DoEvents
    Call EtatClasse("Ecriture du fichier de destination")
    Select Case TypeFile_Dest
        Case 0
    '--- ACCESS
            EcritFileDest = EcritBaseAccess
Call EtatClasse("Ecriture dans la base de donnée terminée", 1)
        Case 1
    '--- EXCEL
            EcritFileDest = EcritClasseurXL
Call EtatClasse("Ecriture dans le fichier Excel terminée", 1)
        Case 2
    '--- TEXTE
            EcritFileDest = EcritFichierTexte
Call EtatClasse("Ecriture dans le fichier Texte terminée", 1)
    End Select
End Function
Private Function LectFileSrc() As Boolean
    DoEvents
Call EtatClasse("Lecture du fichier source")
    Select Case TypeFile_Src
        Case 0
    '--- ACCESS
            LectFileSrc = LitBaseAccess
Call EtatClasse("Lecture de la base de donnée terminée", 1)
        Case 1
    '--- EXCEL
            LectFileSrc = LitClasseurXL
Call EtatClasse("Lecture du fichier Excel terminée", 1)
        Case 2
    '--- TEXTE
            LectFileSrc = LitFichierTexte
Call EtatClasse("Lecture du fichier Texte terminée", 1)
    End Select
End Function
Private Function EcritBaseAccess() As Boolean
'------------------------------------------'
'---   ECRITURE DE LA BASE DE DONNEES   ---'
'------------------------------------------'
    On Error GoTo Err_EcritBaseAccess
    Dim MyConnection As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim connCat As ADOX.Catalog
    Dim strTmpSQL As String
    Dim Fso
    
    Dim NumTable As Integer, NumChamp As Integer
    Dim TabRec As Variant, NumRec As Integer
    Dim TabValeurs As Variant
    Dim NumVal  As Integer
    Dim stringConnection As String
    Set MyConnection = New ADODB.Connection
    Set connCat = New ADOX.Catalog
    Set Rst = New ADODB.Recordset
'---    si on a demandé à écraser, on crée la base
    If OverWriteDest = True Then
Call EtatClasse("Suppression de la base de données", 1)
    '--- si le fichier existe ==> suppression
        If Dir(PathFile_Dest) <> "" Then
            Set Fso = CreateObject("scripting.filesystemobject")
            Fso.DeleteFile PathFile_Dest, True
            Set Fso = Nothing
        End If
    '--- création de la bdd
Call EtatClasse("Création de la base de données", 1)
        connCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & PathFile_Dest & ";"
    Else
'****(TODO = Penser à supprimer les enregistrements dans les tables, en pensant aux raltions existante !!)
    End If
'--- Connexion à la base
Call EtatClasse("Connexion à la base de données", 1)
    stringConnection = "driver={Microsoft Access Driver (*.mdb)};UID=" & GlobalUser_Access & ";PWD=" & GlobalPass_Access & ";DBQ=" & PathFile_Dest & ";SystemDb=" & GlobalSystemDB_Access & ";"
    MyConnection.Open stringConnection
    Do While Dir(PathFile_Dest) = ""
        DoEvents
    Loop
    Set connCat.ActiveConnection = MyConnection
'--- création des tables
    For NumTable = 0 To UBound(TableauSrc)
        On Error Resume Next
        strTmpSQL = "SELECT * FROM [" & TableauSrc(NumTable)(0) & "];"
        MyConnection.Execute (strTmpSQL)
        If Err = 0 Then
    '--- pas d'erreur, c ke la table existe. on la supprime
            strTmpSQL = "DROP TABLE [" & TableauSrc(NumTable)(0) & "];"
            MyConnection.Execute strTmpSQL
        End If
        On Error GoTo Err_EcritBaseAccess
    '--- on peut créer la table maintenant
        strTmpSQL = "CREATE TABLE [" & TableauSrc(NumTable)(0) & "] ("
    '--- crée l'instruction SQL avec la liste des champs
        For NumChamp = 0 To UBound(TableauSrc(NumTable)(1))
            strTmpSQL = strTmpSQL & "[" & Trim(TableauSrc(NumTable)(1)(NumChamp)) & "] memo,"
        Next
    '--- enlève le FieldSeparator de la fin
        strTmpSQL = Left(strTmpSQL, Len(strTmpSQL) - 1)
        strTmpSQL = strTmpSQL & ");"
Debug.Print strTmpSQL
        MyConnection.Execute strTmpSQL
    '--- on va ajouter les enregistrements dans cette table
        TabRec = Split(TableauSrc(NumTable)(2), vbCrLf)
    '--- pour chaque enregistrement
        For NumRec = 0 To UBound(TabRec)
            If TabRec(NumRec) <> "" Then
                strTmpSQL = "INSERT INTO [" & TableauSrc(NumTable)(0) & "] VALUES ("
                TabValeurs = Split(TabRec(NumRec), FieldSeparator)
                For NumVal = 0 To UBound(TabValeurs)
                    strTmpSQL = strTmpSQL & "'" & Trim(TabValeurs(NumVal)) & "',"
                Next
            '--- enlève le FieldSeparator de la fin
                strTmpSQL = Left(strTmpSQL, Len(strTmpSQL) - 1)
                strTmpSQL = strTmpSQL & ");"
Debug.Print strTmpSQL
            MyConnection.Execute strTmpSQL
            End If
        Next
    Next
    EcritBaseAccess = True
Exit_EcritBaseAccess:
Call EtatClasse("Fermeture de la base de données", 1)
    On Error Resume Next
    Set Rst = Nothing
    If MyConnection.State = 1 Then
        MyConnection.Close
    End If
    Set MyConnection = Nothing
    Set connCat = Nothing
    Exit Function
Err_EcritBaseAccess:
    If Err.Number = 13 Then
    '--- erreur générée lors de la suppression de la base
        Resume Next
    ElseIf Err.Number = 70 Then
    '--- permission refusée, le fichier doit être déjà ouvert
        Call AlerteClasse("ECRIT BASE ACCESS", "Erreur :" & Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Si le fichier est déjà ouvert, fermez-le et relancez la conversion")
        EcritBaseAccess = False
        GoTo Exit_EcritBaseAccess
    Else
        Call AlerteClasse("ECRIT BASE ACCESS", "Erreur :" & Err.Number & vbCrLf & Err.Description)
        EcritBaseAccess = False
        GoTo Exit_EcritBaseAccess
    End If
End Function

Private Function LitBaseAccess() As Boolean
'-----------------------------------------'
'---   LECTURE DE LA BASE DE DONNEES   ---'
'-----------------------------------------'
    On Error GoTo Err_LitBaseAccess
    Dim MyConnection As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim connCat As ADOX.Catalog
    Dim stringConnection As String
    
    Dim NumTable As Integer, IdChp As Integer, TailleTab As Integer
    Dim strValeurs As String, strTmpSQL As String
    Dim TmpTab(), TabChamps()
    
    Set MyConnection = New ADODB.Connection
    Set connCat = New ADOX.Catalog
'--- ouvre la base
Call EtatClasse("Connexion à la base de données", 1)
    stringConnection = "driver={Microsoft Access Driver (*.mdb)};UID=" & GlobalUser_Access & ";PWD=" & GlobalPass_Access & ";DBQ=" & PathFile_Src & ";SystemDb=" & GlobalSystemDB_Access & ";"
    MyConnection.Open stringConnection
    Set connCat.ActiveConnection = MyConnection
    
Call EtatClasse("Recherche des tables", 1)
'--- liste l'ensemble des tables de la base de donnée
    TailleTab = 0
    For NumTable = 0 To connCat.Tables.Count - 1
        DoEvents
        If connCat.Tables(NumTable).Type = "TABLE" Then
            ReDim Preserve TmpTab(TailleTab)
        '--- on stocke ds tab temporaire la liste des tables
            TmpTab(TailleTab) = Trim(connCat.Tables(NumTable).Name)
            TailleTab = TailleTab + 1
        End If
    Next
'--- pour chaque tables stockée temporaire, on va liste les enregistrements.
    ReDim TableauSrc(UBound(TmpTab))
    For NumTable = 0 To UBound(TmpTab)
Call EtatClasse("Lecture des enregistrements de la table '" & TmpTab(NumTable) & "'", 1)
        strTmpSQL = "SELECT * FROM [" & TmpTab(NumTable) & "] "
        Set Rst = MyConnection.Execute(strTmpSQL)
    '--- Stocke la liste des champs
        TailleTab = 0
        For IdChp = 0 To Rst.Fields.Count - 1
            DoEvents
            ReDim Preserve TabChamps(TailleTab)
            TabChamps(TailleTab) = Rst.Fields(IdChp).Name
            TailleTab = TailleTab + 1
        Next
    '--- stocke dans strValeurs l'ensemble des lignes
   '--- pas besoin de movenext quand on fait un GetString
        If Not Rst.EOF Then
            strValeurs = Rst.GetString(adClipString, -1, FieldSeparator, vbCrLf)
        Else
            strValeurs = ""
        End If
        TableauSrc(NumTable) = Array(TmpTab(NumTable), TabChamps(), strValeurs)
    Next
    LitBaseAccess = True
    If Rst.State = 1 Then
        Rst.Close
    End If
    Set Rst = Nothing
Exit_LitBaseAccess:
Call EtatClasse("Fermeture de la base de données", 1)
    On Error Resume Next
    If MyConnection.State = 1 Then
        MyConnection.Close
    End If
    Set MyConnection = Nothing
    Set connCat = Nothing
    Exit Function
Err_LitBaseAccess:
'--- Erreur due à la présence du mdw ki nécéssite des users et pwd.

'    stringConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & PathFile_Src & ";"
'   Resume
    Call AlerteClasse("LECTURE BASE ACCESS", "Erreur :" & Err.Number & vbCrLf & Err.Description)
    LitBaseAccess = False
    GoTo Exit_LitBaseAccess
End Function
Private Function LitClasseurXL() As Boolean
'-------------------------------------'
'---   LECTURE DU CLASSEUR EXCEL   ---'
'-------------------------------------'
    On Error GoTo Err_LitExcel
'    Dim appExcel As Excel.Application
'    Dim tmpWorkbook As Excel.Workbook
'    Dim tmpSheet As Excel.Worksheet
    Dim appExcel As Object
    Dim tmpWorkbook
    Dim tmpSheet
    
    Dim NumFeuille As Integer, TailleTab As Integer
    Dim LigneMax As Long, ColonneMax As Long
    Dim strValeurs As String, tmpLigne As String, tmpChamps As String
    
Call EtatClasse("Ouverture du classeur Excel", 1)
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Visible = False
    appExcel.DisplayAlerts = False
    Set tmpWorkbook = appExcel.Workbooks.Open(PathFile_Src)
    TailleTab = 0
'--- pour chaque feuille --> récupère le nom et les valeurs
Dim XLrw As Long, XLcol As Long
    ReDim TableauSrc(tmpWorkbook.Worksheets.Count - 1)
'--- pour chaque feuille ...
    For NumFeuille = 1 To tmpWorkbook.Worksheets.Count
        DoEvents
        Set tmpSheet = tmpWorkbook.Worksheets(NumFeuille)
Call EtatClasse("Lecture de la feuille '" & tmpSheet.Name & "'", 1)
'        If tmpSheet.Range("A1").Value <> "" Then
'            ColonneMax = tmpSheet.Range("A1").End(xlToRight).Column
'            LigneMax = tmpSheet.Range("A1").End(xlDown).Row
'        ElseIf tmpSheet.Range("A2").Value <> "" Then
'            ColonneMax = tmpSheet.Range("A2").End(xlToRight).Column
'            LigneMax = tmpSheet.Range("A2").End(xlDown).Row
'        Else
'            ColonneMax = 0
'            LigneMax = 0
'        End If
'        If LigneMax >= 65535 Then
'            LigneMax = 1
'        End If
'        If ColonneMax >= 256 Then
'            ColonneMax = 1
'        End If
        strValeurs = ""
    '--- pour ne plus utiliser les références spécifiques à excel, on part du principe que la première ligne du fichier excel contient les valeurs sans champs vides
        ColonneMax = 1
        Do While tmpSheet.Cells(1, ColonneMax) <> ""
            ColonneMax = ColonneMax + 1
        Loop
        ColonneMax = ColonneMax - 1
    '--- pour chaque ligne ...
        XLrw = 1
        Do
            DoEvents
            tmpLigne = ""
        '--- pour chaque colonne ...
            For XLcol = 1 To ColonneMax
                DoEvents
                tmpLigne = tmpLigne & tmpSheet.Cells(XLrw, XLcol) & FieldSeparator
            Next
            If Replace(tmpLigne, FieldSeparator, "") = "" Then Exit Do
            If XLrw = 1 And FirstLigneAsChamps = True Then
        '--- on vient de lire la première ligne et la premiere ligne contient les noms des champs ==> stocke
            '--- enlève le ; de la fin
                If Replace(tmpLigne, FieldSeparator, "") <> "" Then
                    tmpChamps = Left(tmpLigne, Len(tmpLigne) - 1)
                Else
                    tmpChamps = ""
                End If
            Else
                strValeurs = strValeurs & Left(tmpLigne, Len(tmpLigne) - 1) & vbCrLf
            End If
            XLrw = XLrw + 1
        Loop
    '--- stocke le nom de la feuille
        TableauSrc(NumFeuille - 1) = Array(tmpSheet.Name, Split(tmpChamps, FieldSeparator), strValeurs)
        Set tmpSheet = Nothing
    Next
    LitClasseurXL = True
Exit_LitClasseurXL:
    On Error Resume Next
Call EtatClasse("Fermeture du fichier Excel", 1)
    tmpWorkbook.Close
    Set tmpWorkbook = Nothing
    appExcel.application.quit
    appExcel.quit
    Set appExcel = Nothing
    Exit Function
Err_LitExcel:
    Call AlerteClasse("LECTURE CLASSEUR EXCEL", "Erreur :" & Err.Number & vbCrLf & Err.Description)
    LitClasseurXL = False
    GoTo Exit_LitClasseurXL
End Function
Private Function EcritClasseurXL() As Boolean
'--------------------------------------'
'---   ECRITURE DU CLASSEUR EXCEL   ---'
'--------------------------------------'
    On Error GoTo Err_EcritExcel
'    Dim appExcel As Excel.Application
'    Dim tmpWorkbook As Excel.Workbook
'    Dim tmpSheet As Excel.Worksheet
    Dim appExcel
    Dim tmpWorkbook
    Dim tmpSheet
    
    Dim NumFeuille As Integer, NumChamp As Integer
    
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Visible = False
    appExcel.DisplayAlerts = False
'--- en fonction du paramètre d'entrée, on crée ou modifie un classeur excel
    If OverWriteDest = True Then
'--- on crée un classeur excel en supprimant l'ancien
Call EtatClasse("Création du classeur Excel", 1)
        Set tmpWorkbook = appExcel.Workbooks.Add
        tmpWorkbook.SaveAs (PathFile_Dest)
    Else
'--- on modifie un classeur excel . Les feuilles du même nom que celles à créer seront supprimées
Call EtatClasse("Ouverture du classeur Excel", 1)
        Set tmpWorkbook = appExcel.Workbooks.Open(PathFile_Dest)
    End If
'--- on a le TableauSource ki est remplit.
    For NumFeuille = 0 To UBound(TableauSrc)
    On Error Resume Next
        Set tmpSheet = tmpWorkbook.Worksheets(TableauSrc(NumFeuille)(0))
        If Err <> 0 Then
Call EtatClasse("Création de la feuille '" & TableauSrc(NumFeuille)(0) & "'", 1)
        '--- ajouteune feuille
            Set tmpSheet = tmpWorkbook.Worksheets.Add()
        '--- attribue le nom de la table
            tmpSheet.Name = TableauSrc(NumFeuille)(0)
        Else
        '--- on supprime pas la feuille, mais on vide les cellules
            tmpSheet.Cells.ClearContents
        End If
    On Error GoTo Err_EcritExcel

        If FirstLigneAsChamps = True Then
    '--- sur la première ligne, on écrit les nom des champs
            For NumChamp = 0 To UBound(TableauSrc(NumFeuille)(1))
'                DoEvents
                tmpSheet.Cells(1, NumChamp + 1) = TableauSrc(NumFeuille)(1)(NumChamp)
            '--- allez, petit effet : on met les noms des champs en gras :) voir les attributs de ".Font" pr le reste (souligné, couleur, couleur de fond, etc ...)
                tmpSheet.Cells(1, NumChamp + 1).Font.Bold = True
            Next
        End If
        Dim tmpContenu
Call EtatClasse("Ecriture des données dans  '" & TableauSrc(NumFeuille)(0) & "'", 1)
        tmpContenu = TableauSrc(NumFeuille)(2)
    '--- on remplace le caractère de séparation des champs (FieldSeparator) par des tabulations...
        tmpContenu = Replace(tmpContenu, FieldSeparator, vbTab)
    '--- , et on copie tt ça ds le presse papier
        Clipboard.Clear
    '--- vbCFText, c pr préciser ke c du texte.
        Clipboard.SetText tmpContenu, vbCFText
    '--- on colle dans la première cellule d'excel ki , comme un grand sait que
    '---        'vbTab' c pour passer à la cellule suivante
    '---        'vbCrlf', c pr passer à la ligne suivante !!sympa excel !
        If tmpSheet.Range("A1").Value = "" Then
            tmpSheet.Paste tmpSheet.Range("A1")
        Else
            tmpSheet.Paste tmpSheet.Range("A2")
        End If
        Clipboard.Clear
    '--- auto fit c pr redimensionner ttes les colonnes à la taille du contenu.
        tmpSheet.Columns.AutoFit
        Set tmpSheet = Nothing
    Next
    tmpWorkbook.Save
Call EtatClasse("Sauvegarde du classeur Excel ", 1)
    EcritClasseurXL = True
Exit_EcritClasseurXL:
    On Error Resume Next
    tmpWorkbook.Close
    Set tmpWorkbook = Nothing
    appExcel.quit
    Set appExcel = Nothing
    Exit Function
Err_EcritExcel:
    If Err.Number = 70 Then
    '--- permission refusée, le fichier doit être déjà ouvert
        Call AlerteClasse("ECRITURE CLASSEUR EXCEL", "Erreur :" & Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Si le fichier est déjà ouvert, fermez-le et relancez la conversion")
        EcritClasseurXL = False
        GoTo Exit_EcritClasseurXL
    Else
        Call AlerteClasse("ECRITURE CLASSEUR EXCEL", "Erreur :" & Err.Number & vbCrLf & Err.Description)
        EcritClasseurXL = False
        GoTo Exit_EcritClasseurXL
    End If
End Function
Private Function EcritFichierTexte() As Boolean
'-------------------------------------'
'---   ECRITURE DU FICHIER TEXTE   ---'
'-------------------------------------'
'***TODO
    Dim Fso, File
    Dim NumTable As Integer
    Dim NumChamps As Integer, strChamps As String
    On Error GoTo Err_EcritFichierTexte
    Set Fso = CreateObject("Scripting.FileSystemObject")
    DoEvents
Call EtatClasse("Création du fichier texte", 1)
    Set File = Fso.CreateTextFile(PathFile_Dest, True, False)
    For NumTable = 0 To UBound(TableauSrc)
        DoEvents
Call EtatClasse("Ecriture de la table '" & TableauSrc(NumTable)(0) & "'", 1)
        File.WriteLine "<--Debut de la table-->"
        File.WriteLine "[" & TableauSrc(NumTable)(0) & "]"
        If FirstLigneAsChamps = True Then
            strChamps = ""
            For NumChamps = 0 To UBound(TableauSrc(NumTable)(1))
                DoEvents
                strChamps = strChamps & TableauSrc(NumTable)(1)(NumChamps) & FieldSeparator
            Next
            strChamps = Left(strChamps, Len(strChamps) - 1)
            DoEvents
            File.WriteLine strChamps
        End If
        File.Write TableauSrc(NumTable)(2)
        File.WriteLine "<--Fin de la table-->"
    Next
Call EtatClasse("Le fichier est écrit avec succés.", 1)
    EcritFichierTexte = True
Exit_EcritFichierTexte:
    On Error Resume Next
    File.Close
    Set File = Nothing
    Set Fso = Nothing
    Exit Function
Err_EcritFichierTexte:
    If Err.Number = 70 Then
    '--- permission refusée, le fichier doit être déjà ouvert
        Call AlerteClasse("ECRIT FICHIER TEXTE", "Erreur :" & Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Si le fichier est déjà ouvert, fermez-le et relancez la conversion")
        EcritFichierTexte = False
        GoTo Exit_EcritFichierTexte
    Else
        Call AlerteClasse("ECRITURE FICHIER TEXTE", "Erreur :" & Err.Number & vbCrLf & Err.Description)
        EcritFichierTexte = False
        GoTo Exit_EcritFichierTexte
    End If
End Function
Private Function LitFichierTexte() As Boolean
'------------------------------------'
'---   LECTURE DU FICHIER TEXTE   ---'
'------------------------------------'
'--- Il peut y avoir 2 type de fichiers texte :
'---    Avec une seule table (crées depuis excel, acces, etc ...)
'---    Ceux avec plusieurs tables (crées depuis cette application !)
'---    S'il y a plusieurs tables, les noms des tables sont sous la forme "[Nom de la table]"
'---    donc si le premier caractère de la première ligne n'est pas "[", il n'y a qu'une table.
    Dim Fso, File
    Dim strValeurs As String, strChamps As String, strNomTable
    Dim TabContenu  As Variant, strTmp As String
    Dim TabTable As Variant, NumTable As Integer
    Dim TabChamps
    Dim TabValeurs
    Dim strLine As String, NumLigne As Integer
    Dim ContenuTexte As Variant
    
    On Error GoTo Err_LitFichierTexte
    NumLigne = 0
    strValeurs = ""
    strTmp = ""
    strChamps = ""
    strLine = ""
    Set Fso = CreateObject("Scripting.FileSystemObject")
    DoEvents
Call EtatClasse("Recherche du fichier", 1)
    If Fso.FileExists(PathFile_Src) Then
Call EtatClasse("Ouverture du fichier texte", 1)
        Set File = Fso.OpenTextFile(PathFile_Src, , False)
    '--- on va lire tout le contenu
        ContenuTexte = File.ReadAll
Call EtatClasse("Recherche de contenu", 1)
        If ContenuTexte <> "" Then
            If Left(ContenuTexte, 3) = "<--" Then
        '--- multiTable !
                TabContenu = Split(ContenuTexte, "<--Fin de la table-->" & vbCrLf)
                ReDim TableauSrc(UBound(TabContenu) - 1)
                For NumTable = 0 To UBound(TabContenu) - 1
                    DoEvents
                    TabTable = Split(TabContenu(NumTable), vbCrLf)
                    strValeurs = ""
                    strChamps = ""
                    strNomTable = ""
                    For NumLigne = 1 To UBound(TabTable) - 1
                        DoEvents
                        If TabTable(NumLigne) <> "" Then
                            If NumLigne = 1 Then
                            '--- récupère le nom de la table
                                strNomTable = Mid(TabTable(NumLigne), 2, Len(TabTable(NumLigne)) - 2)
                            ElseIf FirstLigneAsChamps = True And NumLigne = 2 Then
                                strChamps = TabTable(NumLigne)
                            Else
                                strValeurs = strValeurs & TabTable(NumLigne) & vbCrLf
                            End If
                        End If
                    Next
                    TableauSrc(NumTable) = Array(strNomTable, Split(strChamps, FieldSeparator), strValeurs)
                Next
            Else
Call EtatClasse("Le fichier ne contient qu'une seule source de données", 1)
        '--- une seule table
            '--- on enlève 2 caractère à cause du vbCrLf qui est en fait chr(10) + chr(13)
                strNomTable = Mid(PathFile_Src, InStrRev(PathFile_Src, "\") + 1)
                strNomTable = Left(strNomTable, InStrRev(strNomTable, ".") - 1)
                If FirstLigneAsChamps = True Then
                    strChamps = Left(ContenuTexte, InStr(ContenuTexte, vbCrLf) - 2)
                    strValeurs = Mid(ContenuTexte, InStr(ContenuTexte, vbCrLf) + 2)
                Else
                        strChamps = ""
                        strValeurs = ContenuTexte
                End If
                ReDim TableauSrc(0)
                TableauSrc(0) = Array(strNomTable, Split(strChamps, FieldSeparator), strValeurs)
            End If
            LitFichierTexte = True
        Else
Call EtatClasse("Le fichier est vide !", 1)
    '--- pas de contenu = erreur
            LitFichierTexte = False
        End If
        File.Close
        Set File = Nothing
    Else
        LitFichierTexte = False
    End If
Exit_LitFichierTexte:
    On Error Resume Next
    Set Fso = Nothing
    Exit Function
Err_LitFichierTexte:
    Call AlerteClasse("LECTURE FICHIER TEXTE", "Erreur :" & Err.Number & vbCrLf & Err.Description)
    LitFichierTexte = False
    GoTo Exit_LitFichierTexte
End Function
Private Sub Class_Initialize()
    DoEvents
    PathFile_Src = ""
    PathFile_Dest = ""
    TypeFile_Src = 1
    TypeFile_Dest = 2
    OverWriteDest = False
    FirstLigneAsChamps = True
    FieldSeparator = ";"
    TmpProgression = 1
    TmpRapport = ""
End Sub
Private Function AlerteClasse(strTitre, strTexte)
    MsgBox strTexte, vbCritical, strTitre
End Function
Private Function EtatClasse(strRapport As String, Optional Position As Integer = 0)
    Do While TmpRapport <> ""
        DoEvents
    Loop
    TmpRapport = strRapport
    TmpRapport = String(Position, vbTab) & TmpRapport
    TmpProgression = TmpProgression + 1
End Function


