Inclure un fichier dans une base de données Access

Option Compare Database
Option Explicit

Option Base 1

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
        (ByVal nBufferLength As Long, ByVal lpBuffer As String) _ 
        As Long

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

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

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

Private Declare Function CloseHandle Lib "kernel32" _
        (ByVal hObject As Long) _
        As Long

Private Declare Function SetFilePointer Lib "kernel32" _
        (ByVal hFile As Long, _
                ByVal lDistanceToMove As Long, _
                lpDistanceToMoveHigh As Long, _
                ByVal dwMoveMethod As Long) _
        As Long

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

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

Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" _
        (ByVal lpExistingFileName As String, _
                ByVal lpNewFileName As String, _
                ByVal dwFlags As Long) _
        As Long

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

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érationnel
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 différents 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

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

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

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

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

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

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

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

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
        (ByVal lpFileName As String, _
                lpFindFileData As WIN32_FIND_DATA) _
        As Long

Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
        (ByVal hFindFile As Long, _
                lpFindFileData As WIN32_FIND_DATA) _
        As Long

Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
        (ByVal lpFileName As String) _
        As Long

Private Declare Function FindClose Lib "kernel32" _
        (ByVal hFindFile As Long) _
        As Long

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

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

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

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 répertoire (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 répertoire

'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 répertoire 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

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

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

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

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

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

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

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

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

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

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

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

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