Inclure un fichier dans une base de données Access

16/12/2003

Par Gaël (Autres articles)
 

Cet article décrit l'installation et l'utilisation du module Access "File Includer"

• Version Office 97
• Version Office 2003

• Le module MDA
• Une copie de la licence GPL en francais (version non officielle)
• Une copie de la licence GPL en anglais (version officielle)
• Un fichier Release contenant l'historique de mise à jour

• encode_fichier
• encodage_massif

Public Sub encodage_fichier()
Dim li_retour As Integer
li_retour = Compression.encode_fichier("identifiant base", "nom du fichier avec chemin", confirmation)
End Sub

• 1 : Ecrase automatiquement le fichier existant dans la base
• 2 : Annule l'inclusion du fichier
• 3 : Ouvre une boite de dialogue

Public Sub encode_repertoire()
Dim li_retour As Integer
li_retour = Compression.encodage_massif("chemin", "masque", inclure_ss_repertoire, confirmation)
End Sub

• decode_fichier

Public Sub decode_fichier()
Dim ls_retour
ls_retour = Compression.decode_fichier("identifiant base", "nom du fichier avec chemin")
End Sub

• controle_existance
• purge_all
• suppr
• list_fichier
• verifie_tables

Public Sub controle()
Dim lb_test As Boolean
lb_test = Compression.controle_existance("identifiant base")
End Sub

Compression.purge_all

Compression.suppr ("identifiant base")

Public Sub list()
Dim rs As DAO.Recordset
Set rs = list_fichier
End Sub

If Compression.verifie_tables() Then
	MsgBox "ok"
else
	MsgBox "Marche pas"
End If

Compression.Create_database

• Le module "Module de compression"
• Le module "Fonction Recherche fichiers"
• Le module "Creation de base"

Option Compare Database
Option Explicit

Option Base 1

API qui Permet de récuperer le chemin du repertoire temporaire Windows
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
	(ByVal nBufferLength As Long, ByVal lpBuffer As String) _ 
	As Long

API qui permet d'ecrire dans un fichier
Private Declare Function WriteFile Lib "kernel32" _
	(ByVal hFile As Long, _
		lpBuffer As Any, _
		ByVal nNumberOfBytesToWrite As Long, _
		lpNumberOfBytesWritten As Long, _
		ByVal lpOverlapped As Any) _
	As Long

API qui permet de lire un fichier
Private Declare Function ReadFile Lib "kernel32" _
	(ByVal hFile As Long, _
		lpBuffer As Any, _
		ByVal nNumberOfBytesToRead As Long, _
		lpNumberOfBytesRead As Long, _
		ByVal lpOverlapped As Any) _
	As Long

API qui permet de Creer ou ouvrir un fichier
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
	(ByVal lpFileName As String, _
		ByVal dwDesiredAccess As Long, _
		ByVal dwShareMode As Long, _
		ByVal lpSecurityAttributes As Any, _
		ByVal dwCreationDisposition As Long, _
		ByVal dwFlagsAndAttributes As Long, _
		ByVal hTemplateFile As Long) _
	As Long

API qui permet de fermer un handle
Private Declare Function CloseHandle Lib "kernel32" _
	(ByVal hObject As Long) _
	As Long

API qui permet de positionner un pointeur sur un fichier
Private Declare Function SetFilePointer Lib "kernel32" _
	(ByVal hFile As Long, _
		ByVal lDistanceToMove As Long, _
		lpDistanceToMoveHigh As Long, _
		ByVal dwMoveMethod As Long) _
	As Long

API qui permet de changer les attributs d'un fichier
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" _
	(ByVal lpFileName As String, _
		ByVal dwFileAttributes As Long) _
	As Long

Private Declare Function GetFileSize Lib "kernel32" _
	(ByVal hFile As Long, _
		lpFileSizeHigh As Long) _
	As Long

API qui permet de recuperer un nom de fichier temporaire généré par windows
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
	(ByVal lpszPath As String, _
		ByVal lpPrefixString As String, _
		ByVal wUnique As Long, _
		ByVal lpTempFileName As String) _
	As Long

API qui permet de déplacer un fichier
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" _
	(ByVal lpExistingFileName As String, _
		ByVal lpNewFileName As String, _
		ByVal dwFlags As Long) _
	As Long

API qui permet de supprimer un fichier
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" _
	(ByVal lpFileName As String) _
	As Long

'Les constantes ci-dessous sont modifiables
'La constante ci-dessous correspond au nombre de caractères à stocké par colonne 
'(64*2=128) les colonnes doivent etre en texte(128)

Public Const VAL_HACHAGE = 64
'Le nombre de colonne dans la table
Public Const VAL_COLONNE = 14
'Le nom de la table qui contient les données
Public Const TABLE_IMPORT = "Stockage"
'Le nom de la table qui liste les fichiers
Public Const TABLE_FILE = "Listage_fichier"

'Les constantes ci dessous NE DOIVENT EN AUCUN CAS ETRE MODIFIER
Const MOVEFILE_REPLACE_EXISTING = &H1
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const FILE_BEGIN = 0
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2
Const CREATE_NEW = 1
Const OPEN_EXISTING = 3
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000

Fonction decode_fichier
Public Function encode_fichier(nom_fichier_logique As String, _
    nom_fichier_physique As String, confirmation As Integer) As Long
    
Dim rs As Recordset
Dim bbytes() As Byte
Dim bhex() As String
Dim nSize As Long
Dim ret As Long
Dim hOrgFile As Long
Dim ll_i As Long
Dim ll_j As Long
Dim chaine() As String
Dim nb_ligne As Long
Dim val As String
Dim val2 As String
Dim val3 As Double
Dim nboctet As Integer

'on test si le module est opérationel
If Not verifie_tables Then Exit Function

'on regarde si l'index existe déjà dans la table
If controle_existance(nom_fichier_logique) Then
    'suivant le code de confirmation on switch sur les differents cas
    If confirmation = 1 Then
        'on écrase
        suppr (nom_fichier_logique)
    ElseIf confirmation = 2 Then
        'on annule
        encode_fichier = -1
        Exit Function
        'la ou pose la question à l'utilisateur
    ElseIf confirmation = 3 Then
        If MsgBox("Ce fichier logique : " & nom_fichier_logique & _
            " Existe déjà dans la base." & vbCrLf & _
            "Voulez vous l'écraser ?", vbQuestion + vbYesNo) = vbYes Then
            
            'réponse client = ecrase
            suppr (nom_fichier_logique)
        Else
            'réponse client = on annule
            encode_fichier = -1
            Exit Function
        End If
    End If
End If

'on ouvre le fichier dans le handle HorgFile
hOrgFile = CreateFile(nom_fichier_physique, _
    GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    
'on recupère la taille du fichier dans nSize
nSize = GetFileSize(hOrgFile, 0)


'si le fichier est inexistant
If nSize = -1 Then
    encode_fichier = -1
    Exit Function
End If

'on défini un pointeur sur le fichier via son handle
SetFilePointer hOrgFile, 0, 0, FILE_BEGIN
'on redimensionne le tableau bbytes suivant la taille du fichier
ReDim bbytes(nSize) As Byte

'on fait la lecture du fichier et on rempli le tableau bbytes
ReadFile hOrgFile, bbytes(1), UBound(bbytes), ret, ByVal 0&
CloseHandle hOrgFile
'on ferme le handle

'on redimensionne bbhex pour s'aligner avec un multiple de VAL_hachage*2
If nSize Mod VAL_HACHAGE <> 0 Then
    nb_ligne = Int(nSize / VAL_HACHAGE) + 1
    ReDim bhex(VAL_HACHAGE * nb_ligne) As String
Else
    ReDim bhex(nSize) As String
    nb_ligne = nSize / VAL_HACHAGE
End If

'on converti les codes Bbytes en Ascii
For ll_i = 1 To nSize
    val = String(2 - Len(Hex(bbytes(ll_i))), "0")
    val2 = Hex(bbytes(ll_i))
    bhex(ll_i) = val & val2
Next
ReDim chaine(nb_ligne) As String
'on cumul dans le tableau bhex
For ll_i = 1 To nb_ligne
    For ll_j = 1 To VAL_HACHAGE
        chaine(ll_i) = chaine(ll_i) + bhex(((ll_i - 1) * VAL_HACHAGE) + ll_j)
    Next
Next
'ensuite on boucle sur le nb de nb_ligne pour encapsuler ca dans la table
Set rs = CodeDb.OpenRecordset("SELECT * FROM [" & TABLE_IMPORT & "]")

For ll_i = 1 To nb_ligne
    If ll_i Mod VAL_COLONNE = 1 Then
        If ll_i > VAL_COLONNE Then
            rs(2) = nboctet
            nboctet = 0
            rs(VAL_COLONNE + 3) = format(Now(), "dd/mm/yyyy")
            rs.Update
        End If
        rs.AddNew
        rs(0) = nom_fichier_logique
    End If
    val3 = Int((ll_i - 1) / VAL_COLONNE)
    val3 = ll_i - (val3 * VAL_COLONNE)
    rs(val3 + 2) = Trim(chaine(ll_i))
    nboctet = nboctet + (Len(Trim(chaine(ll_i))) / 2)
Next
rs(2) = nboctet
'on colle la date dans la table
rs(VAL_COLONNE + 3) = format(Now(), "dd/mm/yyyy")
rs.Update
'on retourne ensuite la taille du fichier
encode_fichier = nSize

End Function

decode_fichier
Public Function decode_fichier(nom_fichier_logique As String, _
    nom_fichier_physique As String) As String
Dim rs As Recordset
Dim chaine() As String
Dim bbytes() As Byte
Dim ll_i As Long
Dim ll_j As Double
Dim nb_octet As Long
Dim car As String
Dim valeur As Integer
Dim adresse_mem As Long
Dim hNewFile As Long
Dim sTemp As String
Dim chemin As String
Dim ret As Long
If Not verifie_tables Then Exit Function
'on regarde le nb d'octet à définir
Set rs = CodeDb.OpenRecordset("SELECT Sum([" & TABLE_IMPORT & _
    "].Nombre_octet) AS SommeDeNombre_octet FROM [" & TABLE_IMPORT & _
    "] WHERE ((([" & TABLE_IMPORT & "].[Nom du Fichier])='" & _
    nom_fichier_logique & "'));")
nb_octet = rs![SommeDeNombre_octet]

'on sort si problème
If IsNull(rs![SommeDeNombre_octet]) Then
    decode_fichier = ""
    Exit Function
End If

'on redimensionne les 2 tableaux bbytes, et chaine
ReDim bbytes(nb_octet) As Byte
ReDim chaine(Int(nb_octet / VAL_HACHAGE) + 1) As String

Set rs = CodeDb.OpenRecordset("SELECT * FROM [" & TABLE_IMPORT & _
    "] WHERE [Nom du Fichier]='" & nom_fichier_logique & "' ORDER BY [Numéro]")
'on boucle sur toutes les lignes du RecordSet
While Not rs.EOF
    For ll_i = 1 To VAL_COLONNE
        If Not IsNull(rs(ll_i + 2)) Then
            'on rempli le tableau chaine avec la valeur de la table (des octets donc)
            ll_j = ((rs.AbsolutePosition) * VAL_COLONNE) + ll_i
            chaine(ll_j) = rs(ll_i + 2)
        End If
    Next
    rs.MoveNext
Wend
rs.close
'ensuite on boucle sur le tableau chaine
For ll_i = 1 To Int(nb_octet / VAL_HACHAGE) + 1
    For ll_j = 1 To (VAL_HACHAGE * 2) - 1 Step 2
        'on extrait le caractere
        'puis on le converti avec la formule -> val("&h" & chaine(1))
        If ll_j <= Len(chaine(ll_i)) Then
            'on remplis le nouveau table bbytes
            car = Mid(chaine(ll_i), ll_j, 2)
            valeur = val("&h" & car)
            adresse_mem = ((ll_i - 1) * VAL_HACHAGE) + (ll_j + 1) / 2
            bbytes(adresse_mem) = valeur
        End If
    Next
Next
'Ensuite on recode le fichier
'on test si un fichier cible est défini
If Len(Trim(nom_fichier_physique)) = 0 Then
    'non
    sTemp = String(260, 0)
    chemin = String(260, 0)
    'on prend le chemin temporaire de windows
    GetTempPath Len(chemin), chemin
    chemin = Left$(chemin, InStr(1, chemin, Chr$(0)) - 1)
    'on demande à windows le nom d'un fichier temporaire commencant par BDA
    'windows cree un fichier vide (pour la reservation)
    GetTempFileName chemin, "BDA", 0, sTemp
    sTemp = Left$(sTemp, InStr(1, sTemp, Chr$(0)) - 1)
    'on defini le fichier avec les attributs temporaires
    SetFileAttributes sTemp, FILE_ATTRIBUTE_TEMPORARY
    'on ouvre le fichier
    hNewFile = CreateFile(sTemp, GENERIC_WRITE, FILE_SHARE_READ Or _
        FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    
    'on ecrit les données dedans
    WriteFile hNewFile, bbytes(1), UBound(bbytes), ret, ByVal 0&
    'on ferme le handle
    CloseHandle hNewFile
    'on propage le nom du fichier en retour de fonction
    decode_fichier = sTemp
Else
    'oui
    'on regarde si le fichier existe déjà
    If Dir(nom_fichier_physique, vbNormal) <> "" Then
        'oui -> on pose la question pour ecraser ou non
        If MsgBox("Le fichier existe déjà. voulez vous l'écraser par le nouveau ?" _
            , vbQuestion + vbYesNo, "Question") = vbYes Then
            
            'oui on efface
            DeleteFile nom_fichier_physique
        Else
            'non
            nom_fichier_physique = ""
            End
        End If
    End If
    'on ouvre le fichier
    hNewFile = CreateFile(nom_fichier_physique, GENERIC_WRITE, _
        FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, CREATE_NEW, 0, 0)
    
    'on ecrit le fichier
    WriteFile hNewFile, bbytes(1), UBound(bbytes), ret, ByVal 0&
    'on ferme le handle
    CloseHandle hNewFile
    'on retourne le nom de fichier
    decode_fichier = nom_fichier_physique
End If
End Function

encodage_massif
Public Function encodage_massif(path As String, chaine As String, _
    sous_dossier As Boolean, confirmation As Integer) As Integer

'on verifie si le module est opérationnelle
If Not verifie_tables Then Exit Function
'ok -> opérationnel
Dim filecount As Long
Dim dircount As Long
Dim rs As Recordset
'on fait la liste des fichiers
    'on vide la table de listing fichier
    DoCmd.SetWarnings False
    CodeDb.Execute ("DELETE * FROM [" & TABLE_FILE & "]")
    DoCmd.SetWarnings True

'on dresse la liste des fichiers via la fonction FindFilesAPI
FindFilesAPI path, chaine, filecount, dircount, sous_dossier
Set rs = CodeDb.OpenRecordset("SELECT * FROM [" & TABLE_FILE & "]")

'ensuite on boucle sur la table et on encode
While Not rs.EOF
    'encodage par la boucle
    encode_fichier rs![fichier], rs![chemin] & rs![fichier], confirmation
    rs.MoveNext
Wend
'retourne le nb de fichiers encodés
encodage_massif = filecount

controle_existance
Public Function controle_existance(fichier_logique) As Boolean
'on regarde si le module est opérationnel
If Not verifie_tables Then Exit Function
Dim rs As Recordset

'on ouvre un recorset pour voir si le fichier existe
Set rs = CodeDb().OpenRecordset("SELECT * FROM [" & TABLE_IMPORT & _
    "] WHERE [Nom du Fichier]='" & fichier_logique & "'")

If rs.RecordCount > 0 Then
    'oui -> retourne TRUE
    controle_existance = True
Else
    'non retourne False
    controle_existance = False
End If

End Function

purge_all
Public Function purge_all()
'on regarde si le module est opérationnel
If Not verifie_tables Then Exit Function
'ok
DoCmd.SetWarnings False
'on execute une requete de suppression sans distinction
CodeDb.Execute ("DELETE * FROM [" & TABLE_IMPORT & "]")
DoCmd.SetWarnings True
End Function

suppr
Public Function suppr(nom_fichier_logique As String)

'on regarde si le module est opérationnel
If Not verifie_tables Then Exit Function
'ok
DoCmd.SetWarnings False
'on execute une requete de suppresion avec l'argument
CodeDb.Execute ("DELETE * FROM [" & TABLE_IMPORT & _
    "] WHERE [Nom du Fichier]='" & nom_fichier_logique & "'")
DoCmd.SetWarnings True
End Function

list_fichier
Public Function list_fichier() As DAO.Recordset
'on regarde si le module est opérationnel
If Not verifie_tables Then Exit Function
'ok
'on ouvre le recordset qu'on renvoie en retour de la fonction.

'Attention Recorset en DAO !!
Set list_fichier = CodeDb.OpenRecordset("SELECT * FROM [" & TABLE_IMPORT & "]")
End Function

verifie_tables
Public Function verifie_tables() As Boolean
Dim rs As Recordset
'on regarde nos 2 tables dans la table MSysObjects
'Attention Microsoft Stipule que ces tables peuvent etre modifiées par microsoft sans préavis.
'Il est normalement déconseillé de les utiliser.

'Dans la version prochaine, la technique de controle va changer.

Set rs = CodeDb.OpenRecordset("SELECT * FROM [MSysObjects] Where Name='" _
    & TABLE_IMPORT & "' And Type=1")
If rs.RecordCount > 0 Then
    rs.close
    Set rs = CodeDb.OpenRecordset("SELECT * FROM [MSysObjects] Where Name='" _
    & TABLE_FILE & "' And Type=1")
    If rs.RecordCount > 0 Then
        'c'est ok on retourne TRUE
        verifie_tables = True
    Else
        'c'est KO on retourne False
        verifie_tables = False
    End If
Else
    'c'est KO on retourne False
    verifie_tables = False
End If

'Si on est false un petit messagebox
If Not verifie_tables Then
    MsgBox "Table Inexistante dans le complément." & vbCrLf & _
        "Le module n'est pas opérationnel", vbCritical, "Erreur"
End If

End Function

API qui permet de lire le premier fichier trouvé dans une structure
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
	(ByVal lpFileName As String, _
		lpFindFileData As WIN32_FIND_DATA) _
	As Long

API qui permet de lire le fichier suivant trouvé dans une structure
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
	(ByVal hFindFile As Long, _
		lpFindFileData As WIN32_FIND_DATA) _
	As Long

API qui permet de recuperer les attributs d'un fichier
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
	(ByVal lpFileName As String) _
	As Long

API qui permet de fermer le pointeur de recherche
Private Declare Function FindClose Lib "kernel32" _
	(ByVal hFindFile As Long) _
	As Long

Structure pour la gestion de date en attribut de fichier
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Structure recuperant la recherche
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

'la constante ci-dessous peut etre modifiée
Const TABLE_FILE = "Listage_fichier"

'les constantes ci-dessous NE DOIVENT EN AUCUN CAS ETRE MODIFIER
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

StripNulls
Function StripNulls(OriginalStr As String) As String
'Cette fonction permet de supprimer le caractère de fin de chaine d'une chaine quelconque
    'Si on trouve le chr$(0) on rentre dans la boucle
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        'On prend les données à gauche de la chaine.
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    'on affecte la nouvelle chaine à l'argument de sortie.
    StripNulls = OriginalStr
End Function

FindFilesAPI
Function FindFilesAPI(path As String, SearchStr As String, _
	filecount As Long, dircount As Long, sub_dir As Boolean)

'déclaration des variables
Dim filename As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim rs As DAO.Recordset


'On ouvre un curseur sur la table
Set rs = CodeDb().OpenRecordset("SELECT * from [" & TABLE_FILE & "]")

'si le chemin passé en argument n'a pas un \ on le rajoute
If Right(path, 1) <> "\" Then
    path = path & "\"
End If
'Si on veut inclure les sous-répertoire (Sub_dir = true)
If sub_dir Then
    ' Recherche des sous répertoires
    nDir = 0
    'redimensionne ndir
    ReDim dirNames(nDir)
    Cont = True
    
    'on cherche le premier fichier
    hSearch = FindFirstFile(path & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        'on boucle tant que la structure renvoi un nouveau repertoire (vérification avec cont)
        Do While Cont
            DirName = StripNulls(WFD.cFileName)
            If (DirName <> ".") And (DirName <> "..") Then
                If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                    dirNames(nDir) = DirName
                    dircount = dircount + 1
                    nDir = nDir + 1
                    ReDim Preserve dirNames(nDir)
                End If
            End If
            Cont = FindNextFile(hSearch, WFD)
        Loop
        Cont = FindClose(hSearch)
    End If
End If
'fin de recherche des sous repertoire

'on attaque les fichiers
hSearch = FindFirstFile(path & SearchStr, WFD)
Cont = True

If hSearch <> INVALID_HANDLE_VALUE Then
    While Cont
        filename = StripNulls(WFD.cFileName)
        If (filename <> ".") And (filename <> "..") Then
            FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
            filecount = filecount + 1
            'on ajoute le fichier dans la liste
            rs.AddNew
            rs![chemin] = path
            rs![fichier] = filename
            rs.Update
        End If
        Cont = FindNextFile(hSearch, WFD)
    Wend
    Cont = FindClose(hSearch)
End If

If nDir > 0 Then
    For i = 0 To nDir - 1
        'si on accepte les sous repertoire on s'appelle recursivement
        FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(i) & "\", SearchStr, filecount, dircount, sub_dir)
    Next i
End If
End Function

Private dbs As Database
Private tdf As TableDef
Private idx As Index
Private rel As Relation

Create_database
Sub Create_database()
Set dbs = CodeDb()
On Error GoTo ErrorHandler
    Call DropTables
    Call CreateTables
    Call CreatePrimaryKeys
    MsgBox "Script successfully processed.", vbInformation
    Exit Sub
    
ErrorHandler:
    Select Case Err.Number
        Case 3010
            MsgBox "Table " & tdf.Name & " already exist!", vbInformation
            Err.Clear
      Case 3284
         MsgBox "Index " & idx.Name & " for table " & tdf.Name & " already exist!", vbInformation
         Err.Clear
        Case Else
            MsgBox Err.Description, vbCritical
    End Select
End Sub

DropTables
Private Sub DropTables()
Call DropTable([Module de compression].TABLE_IMPORT)
Call DropTable([Module de compression].TABLE_FILE)
End Sub

CreateTables
Private Sub CreateTables()
Call CreateTable1 'Listage_fichier
Call CreateTable2 'Stockage
End Sub

CreateTable1
Private Sub CreateTable1()
Set tdf = dbs.CreateTableDef([Module de compression].TABLE_FILE)
Call AddFieldToTable("Chemin", dbText, 255, 0, "", "", "", False, False)
Call AddFieldToTable("Fichier", dbText, 255, 0, "", "", "", False, False)
dbs.TableDefs.Append tdf
End Sub

CreateTable2
Private Sub CreateTable2()
Dim li_i As Integer
Set tdf = dbs.CreateTableDef([Module de compression].TABLE_IMPORT)
Call AddFieldToTable("Nom du Fichier", dbText, 255, 0, "", "", "", False, False)
Call AddFieldToTable("Numéro", dbLong, 0, dbAutoIncrField, "", "", "", False, False)
Call AddFieldToTable("Nombre_octet", dbLong, 0, 0, "0", "", "", False, False)

'Ici on fait la création suivant le type de données des constantes déclarés
For li_i = 1 To [Module de compression].VAL_COLONNE
    Call AddFieldToTable("Fichier" & li_i, dbText, [Module de compression].VAL_HACHAGE * 2, 0, "", "", "", False, False)
Next

Call AddFieldToTable("Date", dbText, 10, 0, "", "", "", False, False)
dbs.TableDefs.Append tdf
End Sub

CreatePrimaryKeys
Private Sub CreatePrimaryKeys()
Set tdf = dbs.TableDefs([Module de compression].TABLE_IMPORT)
Set idx = tdf.CreateIndex("PrimaryKey")

idx.Primary = True
idx.Unique = True
idx.IgnoreNulls = False

Call AddFieldToIndex("Nom du Fichier", False)
Call AddFieldToIndex("Numéro", False)

tdf.Indexes.Append idx

End Sub

DropTable
Private Sub DropTable(TableName As String)
Set tdf = Nothing
On Error Resume Next
Set tdf = dbs.TableDefs(TableName)
On Error GoTo 0
If Not tdf Is Nothing Then dbs.TableDefs.Delete (TableName)
End Sub

DropIndex
Private Sub DropIndex(TableName As String, IndexName As String)

Set tdf = Nothing
Set idx = Nothing
On Error Resume Next
Set tdf = dbs.TableDefs(TableName)
Set idx = tdf.Indexes(IndexName)
On Error GoTo 0
If (Not tdf Is Nothing) And (Not idx Is Nothing) Then tdf.Indexes.Delete (IndexName)
End Sub

AddFieldToTable
Private Sub AddFieldToTable(FieldName As String, DataType As String, _
    SizeCol As Integer, Attributes As Long, DefaultValue As Variant, _
    ValText As String, ValRule As String, NotN As Boolean, ZeroLength As Boolean)
Dim fld As Field

Set fld = tdf.CreateField(FieldName, DataType)
If SizeCol <> 0 Then
    fld.Size = SizeCol
End If
If Attributes <> 0 Then
    fld.Attributes = Attributes
End If
fld.Required = NotN
If DataType = dbText Or DataType = dbMemo Then fld.AllowZeroLength = ZeroLength
fld.DefaultValue = DefaultValue
fld.ValidationRule = ValRule
fld.ValidationText = ValText
tdf.Fields.Append fld

End Sub

AddPropertyToTable
Private Sub AddPropertyToTable(PropertyName As String, Value As Variant, DataType As String)
Dim prp As Property
Set prp = tdf.CreateProperty(PropertyName, DataType, Value)
tdf.Properties.Append prp
End Sub

AddPropertyToField
Private Sub AddPropertyToField(FieldName As String, PropertyName As String, Value As Variant, DataType As String)
Dim prp As Property
Dim fld As Field
Set fld = tdf.Fields(FieldName)
Set prp = fld.CreateProperty(PropertyName, DataType, Value)
fld.Properties.Append prp
End Sub

AddFieldToIndex
Private Sub AddFieldToIndex(FieldName As String, Descending As Boolean)

Dim fld As Field
Set fld = idx.CreateField(FieldName)
If Descending = True Then
    fld.Attributes = dbDescending
End If
idx.Fields.Append fld
End Sub