Rem ================================================================
Rem Module : FonctionDB.bas
Rem Fonction : assemblage des fonctions accédant à la couche ODBC
Rem Création : 15/06/2003
Rem Auteur: O. Mamoudou
Rem Modification : 25/06/2009, suppression des fonctions OpenDB() et exportDB()
Rem Remarque: fonctionne sous MS-Access et Visual Basic
Rem ================================================================

'>>
'>> Variables à utiliser par les fonctions de Base des données
'>> ------------------------------------------------------------
Dim dbVector(30) As Variant
Dim num As Integer
Dim connectionText As String
Dim DatabaseName As String

Rem ================================================================
Rem
Rem SECTION POUR LE TRAITEMENT DES ERREURS DANS LE SYSTEME
Rem
Rem ERROR HANDLING
Rem
Rem
Rem ================================================================

'>>
'>> Définition des niveaux de source d'erreurs possibles
'>> Le système à développer doit être à plusieurs niveaux
'>> ------------------------------------------------------------
Public Enum ErrorLevel
Commande = 10 '>> L'erruer survient au niveau des commandes
Application = 20 '>> L'erruer survient au niveau de l'Application
Pilote = 30 '>> L'erruer survient au niveau des fonctions
End Enum

'>> Cette fonction affiche tout simplement un texte de message
Public Function Message(text As String)
Call MsgBox(text, , "Message Application")
End Function

'>> Cette fonction traite une erreur qui survient dans le système
'>> elle en extrait quelques informations nécessaires
Public Function getErrorMessage(error As Object) As String
Dim NL
NL = Chr(13) & Chr(10)
getErrorMessage = NL _
& "-> Coder d'erreur: " & error.Number _
& NL & "-> Message: " & error.Description _
& NL & "-> Source: " & error.Source _
& NL & "-> Contexte: " & error.HelpContext _
& NL & "-> LastError: " & error.LastDllError
End Function

'>>
'>> Cette affiche quelques attributs d'une erreur qui survient dans le système
Public Function showError(FunctionName As String, error As Object)
Dim text As String
Dim NL
NL = Chr(13) & Chr(10)
text = NL & getErrorMessage(error)

If (Right(FunctionName, 2) <> "()") Then
MsgBox "Error in " & FunctionName & "()-> " & text, , "Message d'erreur"
Else
MsgBox "Error in " & FunctionName & "-> " & text, , "Message d'erreur"
End If
End Function

'>>
'>> Cette extrait quelques attributs d'une erreur qui survient dans le système
Public Function getError(FunctionName As String, error As Object) As String
Dim text As String, NL
NL = Chr(13) & Chr(10)
text = getErrorMessage(error)
If (Right(FunctionName, 2) <> "()") Then
getError = NL & "Error in " & FunctionName & "()-> " & text
Else
getError = NL & "Error in " & FunctionName & "-> " & text
End If
End Function

'>>
'>> Renvoie une erreur génerée par une fonction au niveau où
'>> cette dernière a été appelée.
Public Function SendError(text As String, Optional level As Long)
Dim NL
NL = Chr(13) & Chr(10)
Err.Description = NL & "-> Niveau d'erreur: " & level & NL & text
Err.Raise ErrorLevel.Commande, , Err.Description
End Function

Rem ================================================================
Rem
Rem SECTION DES FONCTIONS POUR
Rem LA MANIPULATION DES BASES DES DONNEES
Rem
Rem
Rem
Rem ================================================================

'>>
'>> Executer une syntaxe SQL sur la base des données
'>> Parametres: DatabaseName: String, le nom de la base des données
'>> SQLSyntaxe: String, une syntaxe SQL
'>> Return:
'>>------------------------------------------------------------
Public Function SendSQLToDatabase(DatabaseName As String, SQLSyntaxe As String)
On Error GoTo ErrorMark
'>>------------------------------
Dim results

If (Trim(SQLSyntaxe) <> "") Then
If (UCase(Trim(SQLSyntaxe)) Like "SELECT*") Then
results = SelectSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "INSERT*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "DELETE*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "UPDATE*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "DROP*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "CREATE*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "ALTER*") Then
results = executeSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "PROCEDURE*") Then
results = ProcedureSQL(DatabaseName, SQLSyntaxe)
ElseIf (UCase(Trim(SQLSyntaxe)) Like "PARAMETERS*") Then
results = ProcedureSQL(DatabaseName, SQLSyntaxe)
End If
End If
SendSQLToDatabase = results
'-------------------------------
ExitMark:
Exit Function
ErrorMark:
SendSQLToDatabase = 0
SendError getError("SendSQLToDatabase()", Err), ErrorLevel.Application
Resume ExitMark
End Function

'>>------------------------------------------------------------------
'>> Création des base des données
'>> Parametre: DatabaseName: string, le nom de la base des données à créer
'>> Return: string, information sous forme de textes
'>>----------------------------------------------------------------
Public Function CreerLaBaseDesDonnees(DatabaseName As String) As String
On Error GoTo ErrorMark
'>>-------------------------------
Dim esp As DAO.Workspace
Dim db As DAO.Database
Dim text As String
Dim NL

NL = Chr(13) & Chr(10)
'>>Retourne une référence à l'espace de travail par défaut.
Set esp = DBEngine.Workspaces(0)
'>>Crée un nouvel objet Database.
Set db = esp.CreateDatabase(DatabaseName, dbLangGeneral)
text = " DATABASE " & NL
text = text & " Name: " & db.Name & NL
text = text & " ConnectString: " & db.Connect & NL
text = text & " TransactionsSupported: " & db.Transactions & NL
text = text & " Updatable: " & db.Updatable & NL
text = text & " SortOrder." & db.CollatingOrder & NL
text = text & " Querytimeout: " & db.QueryTimeOut & NL
'>>liberer les references de l'espace de travail
db.Close
Set esp = Nothing
CreerLaBaseDesDonnees = text
'>>-------------------------------
ExitMark:
Exit Function
ErrorMark:
CreerLaBaseDesDonnees = "Impossible de créer la base des données"
SendError getError("CreerLaBaseDesDonnees", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'------------------------------------------------------------------
'>> Connexion et ouverture de la base des données
'>> Parametre: DatabaseName: string, le nom de la base des données à créer
'>> Return: string, information sous forme de textes
'>>----------------------------------------------------------------
Public Function OuvreLaBaseDesDonnees(DatabaseName As String) As String
On Error GoTo ErrorMark
'>>-------------------------------
Dim esp As DAO.Workspace
Dim db As DAO.Database
Dim text As String
Dim NL

NL = Chr(13) & Chr(10)
'>>Retourne une référence à l'espace de travail par défaut.
Set esp = DBEngine.Workspaces(0)
'>>Crée un nouvel objet Database.
Set db = DBEngine.Workspaces(0).OpenDatabase(DatabaseName)
text = " DATABASE " & NL
text = text & " Name: " & db.Name & NL
text = text & " ConnectString: " & db.Connect & NL
text = text & " TransactionsSupported: " & db.Transactions & NL
text = text & " Updatable: " & db.Updatable & NL
text = text & " SortOrder." & db.CollatingOrder & NL
text = text & " Querytimeout: " & db.QueryTimeOut & NL
'>>liberer les references de l'espace de travail
db.Close
Set esp = Nothing
OuvreLaBaseDesDonnees = text
'>>-------------------------------
ExitMark:
Exit Function
ErrorMark:
OuvreLaBaseDesDonnees = "Impossible de créer la base des données"
SendError getError("OuvreLaBaseDesDonnees", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>>------------------------------------------------------------
'>>
'>> Ouvrir la base des données ODBC à l'aide des textes de connexion
'>> Parametre: dsnName:String, le nom de la base des données
'>> connectionText:String, le texte de connexion (user, pwd, etc)
'>> param: Integer, parametre facultatif
'>> Return: String, le nom de la connexion contenant les propriétés de la base des ‘>> données
'>>------------------------------------------------------------
Public Function getConnectionODBCJet(dsnName As String, connectionText As String, Optional param As Integer) As String
On Error GoTo ErrorMark
'>>-------------------------------------------------------------------------------------
Dim wrkJet As DAO.Workspace
Dim db As DAO.Database
Dim dbsLoop As DAO.Database
Dim prpLoop As DAO.Property
Dim text As String, NL, I

text = ""
NL = Chr(13) & Chr(10)
' Crée un objet Workspace Microsoft Jet.
Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)

If (IsMissing(param)) Then
Set db = wrkJet.OpenDatabase(dsnName, , , connectionText)
Else
Set db = wrkJet.OpenDatabase(dsnName, _
dbDriverCompleteRequired, , _
connectionText)
End If


'databaseName = db.Name
text = text & "-----------------------------" & NL
text = text & "DATABASE " & NL
text = text & " Name: " & db.Name & NL
text = text & " ConnectString: " & db.Connect & NL
text = text & " TransactionsSupported: " & db.Transactions & NL
text = text & " Updatable: " & db.Updatable & NL
text = text & " SortOrder." & db.CollatingOrder & NL
text = text & " Querytimeout: " & db.QueryTimeOut & NL
text = text & "-----------------------------" & NL

' Énumère les éléments de la collection Databases.
I = 1
For Each dbsLoop In wrkJet.Databases
text = text & I & "." & " Propriétés de la base de données " & dbsLoop.Name & ": " & NL
On Error Resume Next
' Énumère les éléments de la collection
' Properties de chaque objet Database.
For Each prpLoop In dbsLoop.Properties
If prpLoop.Name = "Connection" Then
' cette propriété renvoie un objet Connection.
text = text & (I + 1) & "." & "Connection[.Name] = " & dbsLoop.Connection.Name & NL
Else
text = text & (I + 1) & "." & " " & prpLoop.Name & " = " & prpLoop & NL
If (prpLoop.Name = "Connect") Then
DatabaseName = extractDatabase(db.Connection.Name, CStr(prpLoop.value))
text = text & "database: " & DatabaseName & NL
End If
End If
I = I + 1
Next prpLoop
On Error GoTo 0
Next dbsLoop
'>>>>>>>>>>>>>>>>>>>>
db.Close
wrkJet.Close
getConnectionODBCJet = text
'>>-------------------------------------------------------------------------------------
ExitMark:
Exit Function
ErrorMark:
getConnectionODBCJet = "Impossible d'ouvrir la connexion '" & connectionText & "'"
SendError getError("getConnectionODBCJet()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>>------------------------------------------------------------
'>>
'>> Ouvrir la base des données ODBC à l'aide des textes de connexion:
''>> Parametre: dsnName:String, le nom de la base des données
'>> connectionText:String, le texte de connexion (user, pwd, etc)
'>> param: Integer, parametre facultatif
'>> Return: String, le nom de la connexion contenant les propriétés de la base des ‘>> données
Public Function getConnectionODBCDirect(connectionName As String, connectionText As String, Optional param As Integer) As String
On Error GoTo ErrorMark
'>>-------------------------------------------------------------------------------------
Dim wrkODBC As DAO.Workspace
Dim db As DAO.Database
Dim dbsLoop As DAO.Database
Dim prpLoop As DAO.Property
Dim text As String, NL, I

text = ""
NL = Chr(13) & Chr(10)
' Crée un objet Workspace Microsoft Jet.
Set wrkODBC = CreateWorkspace("", "admin", "", dbUseODBC)

If (IsMissing(param)) Then
'Set db = wrkODBC.OpenConnection(connectionName, , , connectionText)
Set db = wrkODBC.OpenConnection("", , , connectionText)
Else
'Set db = wrkODBC.OpenConnection(connectionName, _
dbDriverCompleteRequired, , _
connectionText)
Set db = wrkODBC.OpenConnection("", dbDriverCompleteRequired, , connectionText)
End If

text = text & "-----------------------------" & NL
text = text & " DATABASE " & NL
text = text & " Name: " & db.Connection.Name & NL
text = text & " ConnectString: " & db.Connection.Name & NL
text = text & " TransactionsSupported: " & db.Connection.Transactions & NL
text = text & " Updatable: " & db.Connection.Updatable & NL
text = text & " SortOrder." & db.Connection.Database.Name & NL
text = text & " Querytimeout: " & db.Connection.QueryTimeOut & NL
text = text & "-----------------------------" & NL

' Énumère les éléments de la collection Databases.
I = 1
For Each dbsLoop In wrkODBC.Databases
text = text & I & "." & " Propriétés de la base de données " & dbsLoop.Name & ": " & NL
On Error Resume Next
' Énumère les éléments de la collection
' Properties de chaque objet Database.
For Each prpLoop In dbsLoop.Properties
If prpLoop.Name = "Connection" Then
' cette propriété renvoie un objet Connection.
text = text & (I + 1) & "." & "Connection[.Name] = " & dbsLoop.Connection.Name & NL
Else
text = text & (I + 1) & "." & " " & prpLoop.Name & " = " & prpLoop & NL
If (prpLoop.Name = "Connect") Then
DatabaseName = extractDatabase(db.Connection.Name, CStr(prpLoop.value))
text = text & "database: " & DatabaseName & NL
End If
End If
I = I + 1
Next prpLoop
On Error GoTo 0
Next dbsLoop
'>>>>>>>>>>>>>>>>>>>>
db.Close
wrkODBC.Close
getConnectionODBCDirect = text
'>>-------------------------------------------------------------------------------------
ExitMark:
Exit Function
ErrorMark:
getConnectionODBCDirect = "Impossible d'ouvrir la connexion '" & connectionText & "'"
SendError getError("getConnectionODBCDirect()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>> Cette extrait d'un nom de connexion (un texte contenant la base des données et ‘ ses propriétés)
'>> le nom réel de la base des données
'>> Parametre: connectionName:String, le nom de la connexion de la base des ‘ ‘
‘ données
'>> connectionText:String, le texte de connexion (user, pwd, etc)
'>> Return: String, le nom de la base des données
Public Function extractDatabase(connectionName As String, connectionString As String) As String
'---------------------------------
' Déclare les variables.
Dim C, CmdLnLen, I, position
Dim text1, text2 As String
Dim LenText, LenConStr, difLen

' >> Récupère les arguments de chaine de caracteres 'connectString'.
CmdLnLen = 14 + Len(connectionName)
LenConStr = Len(connectionString)
difLen = LenConStr - CmdLnLen
text2 = ""
text1 = Right(connectionString, difLen)
For I = 1 To difLen
C = Mid(text1, I, 1)
' Analyse de caractères ';'.
If (C <> ";") Then
text2 = text2 & C
position = position + 1
ElseIf (C = ";") Then
I = difLen
End If
Next I
'MsgBox "Position: " & position & " Text: " & text2
extractDatabase = Left(text1, position)
'------------------------------------
End Function

'>> Cette fonction exécute une syntaxe SQL sur une base des données
'>>
'>> Param: DatabaseName:String, le nom de la base des données
'>> SQL:String, une syntaxe de type SQL
'>> Return: boolean, VRAI: l'exécution avec succès, NON: échec
Public Function executeSQL(DatabaseName As String, SQL As String) As Boolean
On Error GoTo ErrorMark
'>>>>>>>>>>>>>>>>>>>>>>
Dim ok As Boolean
Dim wks As DAO.Workspace '>> l'environnement de travail
Dim dbWks As DAO.Database '>> la base des données
Dim rstWks As DAO.Recordset '>> la collection des enregistrements

'>>--------------------------------------------
Set wks = CreateWorkspace("", "admin", "", dbUseJet)
Set dbWks = wks.OpenDatabase(DatabaseName)

If (Right(SQL, 1) Like ";") Then
dbWks.execute SQL
Else
dbWks.execute SQL & ";"
End If
executeSQL = True
'>>Fermer ce qui vient de l'exterieur
dbWks.Close
wks.Close
'>>-------------------------------------------
ExitMark:
Exit Function
ErrorMark:
executeSQL = False
SendError getError("executeSQL()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>> Cette fonction exécute une procédure SQL sur une base des données
'>>
'>> Param: DatabaseName:String, le nom de la base des données
'>> SQL:String, une syntaxe de type SQL
'>> Return:String
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function ProcedureSQL(DatabaseName As String, SQL As String) As String
On Error GoTo ErrorMark
'>>>>>>>>>>>>>>>>>>>>>>
Dim ok As Boolean
Dim wks As DAO.Workspace 'l'environnement de travail
Dim dbWks As DAO.Database 'la base des données
Dim rstWks As DAO.Recordset 'la collection des enregistrements
Dim qdf As DAO.QueryDef
Dim vect2D As Variant 'Vecteur à deux dimensions
Dim text As String, NL 'Le resultat sous forme de string

NL = Chr(13) & Chr(10)
text = ""
'>>--------------------------------------------
Set wks = CreateWorkspace("", "admin", "", dbUseJet)
Set dbWks = wks.OpenDatabase(DatabaseName)
' Create a named QueryDef based on the SQL
' statement.
Set qdf = dbWks.CreateQueryDef("ItdseQDF", SQL)
' Create a temporary snapshot-type Recorset.
Set rstWks = qdf.OpenRecordset(dbOpenSnapshot)
' Populate the Recordset.

If (rstWks.RecordCount < 1) Then
text = "Aucun résultat pour: " & SQL
Else
'---------------------------
'>>Imprimer les noms des champs
'---------------------------------
rstWks.MoveLast
rstWks.MoveFirst
vect2D = rstWks.GetRows(rstWks.RecordCount)
text = text & " ["
For ligne = 0 To UBound(vect2D, 1)
text = text & rstWks.Fields(ligne).Name & ","
Next ligne
text = text & "]" & NL
'>>Imprimer les valeurs des champs
'----------------------------------
rstWks.MoveLast
rstWks.MoveFirst
vect2D = rstWks.GetRows(rstWks.RecordCount)
For ligne = 0 To UBound(vect2D, 2)
text = text & " ["
For colonne = 0 To UBound(vect2D, 1)
text = text & vect2D(colonne, ligne) & ", "
Next colonne
text = text & "]; " & NL
Next ligne
End If
'Delete the QueryDef because this is a demonstration.
dbWks.QueryDefs.Delete "ItdseQDF"
'
rstWks.Close
dbWks.Close
wks.Close
'------------------------------
ProcedureSQL = text
'>>-------------------------------------------
ExitMark:
Exit Function
ErrorMark:
ProcedureSQL = "Aucun résultat pour: " & SQL
SendError getError("ProcedureSQL()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>> Cette fonction exécute une requête de type SQL sur une base des données
'>>
'>> Param: DatabaseName:String, le nom de la base des données
'>> SQL:String, une syntaxe de type SQL
'>> Return: String, le resultat de la requête est converti en texte brut
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function SelectSQL(DatabaseName As String, SQL As String) As String
On Error GoTo ErrorMark
'>>>>>>>>>>>>>>>>>>>>>>
Dim wks As DAO.Workspace 'l'environnement de travail
Dim dbWks As DAO.Database 'la base des données
Dim rstWks As DAO.Recordset 'la collection des enregistrements
Dim conWks As DAO.Connection
Dim text As String 'le critère de recheche
Dim vect2D As Variant 'le critère de recheche
Dim NL, TB

NL = Chr(13) & Chr(10)
TB = Chr(9)
'>>--------------------------------------------
Set wks = CreateWorkspace("", "admin", "", dbUseJet)
Set dbWks = wks.OpenDatabase(DatabaseName)
Set rstWks = dbWks.OpenRecordset(SQL, dbOpenDynaset)
'Set rstWks = dbWks.OpenRecordset(SQL, dbOpenDynamic)

'>>Crée un objet Workspace Microsoft Jet.
'Set wks = CreateWorkspace("", "admin", "", dbUseODBC)
'Set conWks = wks.OpenConnection("Connection", , , connectionText)
'Set rstWks = conWks.OpenRecordset(SQL, dbOpenDynamic)
'>>----------------------------------

text = ""
If (rstWks.RecordCount < 1) Then
text = "Aucun résultat pour: " & SQL
Else

'>>Imprimer les noms des champs
'---------------------------------
rstWks.MoveLast
rstWks.MoveFirst
vect2D = rstWks.GetRows(rstWks.RecordCount)
text = text & " ["
For ligne = 0 To UBound(vect2D, 1)
text = text & rstWks.Fields(ligne).Name & " "
Next ligne
text = text & "]" & NL

'>>Imprimer les valeurs des champs
'----------------------------------
rstWks.MoveLast
rstWks.MoveFirst
vect2D = rstWks.GetRows(rstWks.RecordCount)
For ligne = 0 To UBound(vect2D, 2)
text = text & " ["
For colonne = 0 To UBound(vect2D, 1)
text = text & vect2D(colonne, ligne) & " "
Next colonne
text = text & "]; " & NL
Next ligne
End If
'>>Fermer ce qui vient de l'exterieur
rstWks.Close
dbWks.Close
wks.Close
'>>
SelectSQL = text
'>>-------------------------------------------
ExitMark:
Exit Function
ErrorMark:
SelectSQL = "Aucun résultat pour: " & SQL
SendError getError("executeSQL()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>> Cette fonction extrait des informations sur une base des données
'>>
'>> Param: DatabaseName:String, le nom de la base des données
'>> typeInfo:String, le type d'information à extraire
'>> Return: String, le texte contenant les informations demandées
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function getDatabaseInfo(DatabaseName As String, typeInfo As String) As String
On Error GoTo ErrorMark
' >>--------------------------------------------------------
Dim db As DAO.Database
Dim Td As DAO.TableDef
Dim Fld As DAO.Field
Dim Idx As DAO.Index
Dim Rel As DAO.Relation
Dim I, n As Integer
Dim text As String, NL

Set db = DBEngine.Workspaces(0).OpenDatabase(DatabaseName)
' >>--------------------------------------------------------

NL = Chr(13) & Chr(10)
'CdbProperties
If (typeInfo = "DATABASE") Then

text = " DATABASE " & NL
text = text & " Name: " & db.Name & NL
text = text & " ConnectString: " & db.Connect & NL
text = text & " TransactionsSupported: " & db.Transactions & NL
text = text & " Updatable: " & db.Updatable & NL
text = text & " SortOrder." & db.CollatingOrder & NL
text = text & " Querytimeout: " & db.QueryTimeOut & NL

'CdbTables
ElseIf (typeInfo = "TABLES") Then
For Each Td In db.TableDefs
text = text & " ["
text = text & " Name: " & Td.Name
text = text & " Created: " & Td.DateCreated & ","
text = text & " Updated: " & Td.LastUpdated & ","
If Td.Updatable = True Then
text = text & " Updatable" & ","
Else
text = text & " Not Updatable " & ","
End If
' Show the Tables Attributes.
text = text & " Attributes: " & Hex$(Td.Attributes)
If (Td.Attributes And dbSystemObject) <> 0 Then
text = text & ", System Object "
End If
If (Td.Attributes And dbAttachedTable) <> 0 Then
text = text & ", Attached table "
End If
If (Td.Attributes And dbAttachedODBC) <> 0 Then
text = text & ", Attached ODBC Table "
End If
If (Td.Attributes And dbAttachExclusive) <> 0 Then
text = text & ", Attached Table opened in exclusive mode "
End If
text = text & "]" & NL
Next Td

'CdbFields
ElseIf (typeInfo = "FIELDS") Then
For Each Td In db.TableDefs
For Each Fld In Td.Fields
text = text & " ["
text = text & ", Name: " & Fld.Name
text = text & ", Type: " & Fld.Type
text = text & ", Size:" & Fld.Size
text = text & ", Attributes Bits " & Hex$(Td.Attributes)
text = text & ", CollatingOrder." & Fld.CollatingOrder
text = text & ", OrdinalPosition: " & Fld.OrdinalPosition
text = text & ", SourceField: " & Fld.SourceField
text = text & ", SourceTable: " & Fld.SourceTable
' Show the Field Attributes here if desired,
' as Shown
text = text & ", Attributes: " & Hex$(Fld.Attributes)
If (Fld.Attributes And dbSystemObject) <> 0 Then
text = text & ", System Object"
End If
text = text & "] " & NL
Next Fld 'Get the next Field in the Tables.
Next Td

'CdbIndexes
ElseIf (typeInfo = "INDEXES") Then
For Each Td In db.TableDefs
For Each Idx In Td.Indexes
'Set the Index variable
text = text & " ["
text = text & " Name: " & Idx.Name
text = text & " Clustered: " & Idx.Clustered
text = text & " Foreign: " & Idx.Foreign
text = text & " IgnoreNulls " & Idx.IgnoreNulls
text = text & " Primary " & Idx.Primary
text = text & " Unique " & Idx.Unique
text = text & " Required " & Idx.Required
' Cdb the Fields of the Index.
text = text & " ("
For Each Fld In Idx.Fields
text = text & " Name: " & Idx.Name
text = text & " ForeignName: " & Idx.Foreign
Next Fld ' Get the next Field in the Index.
text = text & ") "
' Get the next Index in the Tables.
Next Idx ' Get next Tables in the Database.
text = text & "] " & NL
Next Td

'CdbRelations
ElseIf (typeInfo = "RELATIONS") Then
For Each Rel In db.Relations
text = text & " ["
text = text & " Name: " & Rel.Name
text = text & " Attributes: " & Rel.Attributes
text = text & " Table: " & Rel.table
text = text & " ForeignTable: " & Rel.ForeignTable
' Cdb the Fields of the Relation
For Each Fld In Rel.Fields
text = text & " Name: " & Fld.Name
text = text & " ForeignName: " & Fld.ForeignName
Next Fld 'Get the next Field in the Relations.
Next Rel 'Get next Relations in the Database.
text = text & "] " & NL
End If
getDatabaseInfo = text
'>>----------------------------------------------------------------
ExitMark:
Exit Function
ErrorMark:
getDatabaseInfo = ""
SendError getError("getDatabaseInfo()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function

'>> Cette fonction extrait des informations sur une table dans la base des données
'>>
'>> Param: DatabaseName:String, le nom de la base des données
'>> table:String, le nom de la table concernée
'>> typeInfo:String, le type d'information à extraire de la table
'>> Return: String, le texte contenant les informations demandées
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public Function getTableInfo(DatabaseName As String, table As String, typeInfo As String) As String
On Error GoTo ErrorMark
' >>--------------------------------------------------------
Dim db As DAO.Database
Dim Td As DAO.TableDef
Dim Fld As DAO.Field
Dim Idx As DAO.Index
Dim Rel As DAO.Relation
Dim I, n As Integer
Dim text As String, NL

Set db = DBEngine.Workspaces(0).OpenDatabase(DatabaseName)

NL = Chr(13) & Chr(10)
'---------------------------------------
'CdbFields
'---------------------------------------
If (typeInfo = "FIELDS") Then
For Each Td In db.TableDefs
If (Td.Name = table) Then
text = text & "Table: " & Td.Name & "( "
For Each Fld In Td.Fields
text = text & " ["
text = text & Fld.Name
'Si la taille = 1
If (Fld.Type = dbBoolean) Then
text = text & ",BOOLEAN"
ElseIf (Fld.Type = dbByte) Then
text = text & ",BYTE"
ElseIf (Fld.Type = dbChar) Then
text = text & ",CHAR"
ElseIf (Fld.Type = dbBinary) Then
text = text & ",BINARY"
ElseIf (Fld.Type = dbBigInt) Then
text = text & ",BIGINTEGER"
ElseIf (Fld.Type = dbVarBinary) Then
text = text & ",VARBINARY"
ElseIf (Fld.Type = dbTime) Then
text = text & ",TIME"
ElseIf (Fld.Type = dbSystemObject) Then
text = text & ",SYSTEMOBJECT"
ElseIf (Fld.Type = 2) Then
text = text & ",SMALLINT"
ElseIf (Fld.Type = dbInteger) Then
text = text & ",INTEGER"
ElseIf (Fld.Type = dbFloat) Then
text = text & ",FLOAT"
ElseIf (Fld.Type = dbSingle) Then
text = text & ",REAL"
'Si la taille = 3
ElseIf (Fld.Type = dbLong) Then
text = text & ",LONG"
'Si la taille = 8
ElseIf (Fld.Type = dbDate) Then
text = text & ",DATE"
ElseIf (Fld.Type = dbCurrency) Then
text = text & ",MONEY"
'Si la taille = 10
ElseIf (Fld.Type = dbDouble) Then
text = text & ",DOUBLE"
ElseIf (Fld.Type = dbDecimal) Then
text = text & ",DECIMAL"
'Si la taille = 10
ElseIf (Fld.Type = dbText) Then
text = text & ",STRING"
ElseIf (Fld.Type = dbMemo) Then
text = text & ",MEMO"
ElseIf (Fld.Type = dbLongBinary) Then
text = text & ",LONGBINARY"
ElseIf (Fld.Type = dbNumeric) Then
text = text & ",NUMERIC"
Else
text = text & ",OBJECT"
End If
'text = text & "," & Fld.Type
text = text & "," & Fld.Size
text = text & "," & Fld.OrdinalPosition
text = text & "," & Hex$(Fld.Attributes)
text = text & "] "
Next Fld 'Get the next Field in the Tables.
text = text & " ); " & NL
End If
Next Td
'---------------------------------------
'CdbIndexes
'---------------------------------------
ElseIf (typeInfo = "INDEXES") Then
For Each Td In db.TableDefs
If (Td.Name = table) Then
text = text & "Table: " & Td.Name & "( "
For Each Idx In Td.Indexes
'Set the Index variable
text = text & " ["
text = text & " Name: " & Idx.Name
text = text & " Clustered: " & Idx.Clustered
text = text & " Foreign: " & Idx.Foreign
text = text & " IgnoreNulls " & Idx.IgnoreNulls
text = text & " Primary " & Idx.Primary
text = text & " Unique " & Idx.Unique
text = text & " Required " & Idx.Required
' Cdb the Fields of the Index.
text = text & " ("
For Each Fld In Idx.Fields
text = text & " Name: " & Idx.Name
text = text & " ForeignName: " & Idx.Foreign
Next Fld ' Get the next Field in the Index.
text = text & ")], "
' Get the next Index in the Tables.
Next Idx ' Get next Tables in the Database.
text = text & "); " & NL
End If
Next Td
'---------------------------------------
'CdbRelations
'---------------------------------------
ElseIf (typeInfo = "RELATIONS") Then
For Each Rel In db.Relations
If (Rel.Name = table) Then
text = text & " Relation: " & Rel.Name & "[ "
text = text & " Attributes: " & Rel.Attributes
text = text & " Table: " & Rel.table
text = text & " ForeignTable: " & Rel.ForeignTable
' Cdb the Fields of the Relation
text = text & "( "
For Each Fld In Rel.Fields
text = text & " Name: " & Fld.Name
text = text & " ForeignName: " & Fld.ForeignName
Next Fld 'Get the next Field in the Relations.
text = text & ")]; " & NL
End If
Next Rel 'Get next Relations in the Database.
End If
'---------------------------------------
'
'---------------------------------------
getTableInfo = text
'>>----------------------------------------------------------------
ExitMark:
Exit Function
ErrorMark:
getTableInfo = ""
SendError getError("getTableInfo()", Err), ErrorLevel.Pilote
Resume ExitMark
End Function