Sub tranfertCSV_Vers_NouvelleTableAccess()
    'Transfére un fichier CSV vers une nouvelle table Access
    'depuis une macro Excel.
    '
    'Nécessite d'activer la référence
    '"Microsoft ActiveX Data Objects x.x Library
    '
 
    Dim AccessCn As ADODB.Connection
    Dim AccessRst As ADODB.Recordset
    Dim Csv_CN As New ADODB.Connection
    Dim Csv_Rst As New ADODB.Recordset
    Dim DossierCSV As String, NomTable As String
    Dim FichCSV As String, MaBase As String
    Dim nbEnr As Long
 
    'Répertoire du fichier CSV
    DossierCSV = "C:\Documents and Settings\mimi\dossier"
    'Nom du fichier CSV à transfèrer
    FichCSV = "LeFichierCSV.csv"
    'Chemin et nom de la base Access
    MaBase = "C:\Documents and Settings\mimi\dossier\dataBase.mdb"
    'Nom de la nouvelle Table Access
    NomTable = "MaNouvelleTable"
 
 
    'Connection au fichier CSV
    Csv_CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
        DossierCSV & ";Extended Properties='text;FMT=Delimited'"
    'Requète dans le fichier CSV
    Csv_Rst.Open "SELECT * FROM " & FichCSV, Csv_CN, _
        adOpenStatic, adLockOptimistic
 
    'Connection à la base de données Access
    Set AccessCn = New ADODB.Connection
    AccessCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & MaBase
 
 
    Csv_CN.Execute "SELECT * INTO [" & NomTable & "] IN '" & _
        MaBase & "' From [" & FichCSV & "]", nbEnr
 
 
    AccessCn.Close
    Csv_Rst.Close
    Csv_CN.Close
    Set AccessRst = Nothing
    Set AccessCn = Nothing
    Set Csv_Rst = Nothing
    Set Csv_CN = Nothing
End Sub

Dim NomBase As String
 
NomBase = "C:\Documents and Settings\mimi\dataBase.mdb"
 
With Sheets("Feuil1").QueryTables.Add(Connection:=Array("OLEDB;Provider=Microsoft.jet.OLEDB.4.0;" & _
        "Data source=" & NomBase), Destination:=Sheets("Feuil1").Range("A1"))
    .CommandText = Array("SELECT * FROM Table1 WHERE CodeClient=42000")
    .Name = "TestRequete"
    .CommandType = xlCmdTable
    .FieldNames = False
    .RowNumbers = False
    .PreserveFormatting = False
    .BackgroundQuery = True
    .RefreshStyle = xlOverwriteCells
    .AdjustColumnWidth = True
    .PreserveColumnInfo = False 'format
    .Refresh BackgroundQuery:=False
End With

Sub VersionMDAC()
    Dim Cn As Object
 
    Set Cn = CreateObject("ADODB.Connection")
    MsgBox "Version MDAC : " & Cn.Version
 
    Set Cn = Nothing
End Sub

Sub creationNouvelleBase()
    'Nécessite d'activer la référence "Microsoft ADO Ext x.x for DLL and Security"
    Dim Cat As ADOX.Catalog
    Dim MaTableIndex As ADOX.Table
    Dim CheminBase As String, NomTable As String
 
    'Chemin et nom de la nouvelle base
    CheminBase = "C:\MaNouvelleBase.mdb"
    'Nom de la table qui va être ajoutée
    NomTable = "MaTable"
 
    Set Cat = New ADOX.Catalog
    'Création base
    Cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CheminBase
 
    Set MaTableIndex = CreateObject("ADOX.Table")
    'Définit les champs pour la nouvelle table
    With MaTableIndex
        .Name = NomTable
        With .Columns
            .Append "ChampDate", adDate, 50
            .Append "ChampNombre", adInteger, 50
            .Append "ChampTexte", adWChar, 80
        End With
    End With
 
    'Création table
    Cat.Tables.Append MaTableIndex
 
    Set Cat = Nothing
    Set MaTableIndex = Nothing
End Sub

Sub AjoutEnregistrementTableAccess()
    'Nécessite d'activer la référence
    '"Microsoft ActiveX Data Objects x.x Library"
 
    Dim Cn As ADODB.Connection
    Dim Fichier As String, TexteSQL As String
 
    Fichier = "C:\NomBase.mdb"
 
    Set Cn = New ADODB.Connection
    Cn.Open "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & Fichier
 
    'Insertion des données dans la Table1 qui contient 3 champs :
        '1 champ date (doit être encadrée par le symbole dièse #)
        '1 champ nombre
        '1 champ texte (doit être encadré par des apostrophes ')
    TexteSQL = "INSERT INTO [Table1] VALUES (#" & _
        Date & "#, " & 12345 & ", '" & Environ("username") & "')"
    Cn.Execute TexteSQL
 
    Cn.Close
    Set Cn = Nothing
End Sub

Sub exportDonnées_DAO()
Dim Db As DAO.Database
Dim strSQL As String
 
Set Db = DAO.OpenDatabase("C:\dossier\dataBase.mdb", False, False)
strSQL = "INSERT INTO [Table1] VALUES('999','8','DVP','7','mimi','22/10/2007')"
 
Db.Execute strSQL
Db.Close
End Sub

Sub importDonnees_DAO()
    Dim Db As DAO.Database
    Dim Rs As DAO.Recordset
    Dim strSQL As String
 
    Set Db = DAO.OpenDatabase("C:\dossier\dataBase.mdb", False, False)
    strSQL = "SELECT * FROM [Table1]"
    Set Rs = Db.OpenRecordset(strSQL, DAO.dbOpenSnapshot)
 
    Range("A1").CopyFromRecordset Rs
 
    Db.Close
End Sub

Sub Tri_Croissant_Champ_BaseAccess()
'Nécessite d 'activer les références :
    'Microsoft ActiveX Data Objects x.x Library
    'et
    'Microsoft ADO Ext. x.x for DDL and Security
Dim Cnn As ADODB.Connection
Dim Cat As ADOX.Catalog
Dim indexTri As ADOX.Index
Dim Rst As New ADODB.Recordset
Dim Fichier As String
 
On Error GoTo Fin
Fichier = "C:\dossier\dataBase.mdb"
 
Set Cnn = New ADODB.Connection
Cnn.Open "Provider='Microsoft.Jet.OLEDB.4.0';" & _
    "Data Source='" & Fichier & "';"
 
Set Cat = New ADOX.Catalog
Set Cat.ActiveConnection = Cnn
 
Set indexTri = New ADOX.Index
With indexTri
    .Columns.Append "NomChamp"
    'tri croissant
    .Columns("NomChamp").SortOrder = adSortAscending
    .Name = "Cible"
 
    'pour les tris décroissants, utilisez :
    '.Columns("NomChamp").SortOrder = adSortDescending
    '.Name = "Cible"
 
    '.IndexNulls = adIndexNullsAllow
End With
 
'ajout d'un index pour la table "LesPoints"
'attention : renvoie une erreur si un index existe déja.
Cat.Tables("LesPoints").Indexes.Append indexTri
 
'suppression index
'Cat.Tables("LesPoints").Indexes.Delete "Cible"
 
Fin:
Cnn.Close
Set Cat = Nothing
Set indexTri = Nothing
Set Rst = Nothing
Set Cnn = Nothing
End Sub

Sub listerConnectesBaseAccess_V01()
    Dim Cible As String
    Dim strLigne As String
 
    'Le fichier .ldb est créé à l'ouverture de la base et supprimé lors de la fermeture.
    'Ce fichier LDB contient le nom des utilisateurs.
    Cible = "C:\Documents and Settings\dossier\dataBase.ldb"
 
    'vérifie si le fichier existe
    If Dir(Cible) = "" Then Exit Sub
 
    Open Cible For Input As #1
        Do While Not EOF(1)
            Line Input #1, strLigne
            Debug.Print strLigne
        Loop
    Close #1
 
End Sub

Sub listerConnectesBaseAccess_V02()
    Dim Cnn As Object
    Dim Rst As Object
    Dim Fichier As String
 
    Const JET_SCHEMA_USERROSTER = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
 
    Fichier = "C:\Documents and Settings\dossier\dataBase.mdb"
    If Dir(Fichier) = "" Then Exit Sub
 
    Set Cnn = CreateObject("ADODB.Connection")
    Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";"
 
    Set Rst = CreateObject("ADODB.Recordset")
    'adSchemaProviderSpecific = -1
    Set Rst = Cnn.OpenSchema(-1, , JET_SCHEMA_USERROSTER)
 
    Debug.Print Rst.GetString
 
    Cnn.Close
    Set Rst = Nothing
    Set Cnn = Nothing
End Sub

Sub Test()
    TransfertAccess_Vers_Excel "C:\SauvegardeClasseur.xls", "NomFeuille"
End Sub
 
 
Sub TransfertAccess_Vers_Excel(NomClasseur As String, maFeuille As String)
    Dim AccessCnn As ADODB.Connection
    Dim maBase As String, maTable As String
    Dim nbEnr As Long
 
    'Chemin de la base Access
    maBase = "C:\Documents and Settings\dossier\database.mdb"
    'Nom de la table Access
    maTable = "Table1"
 
    'Connection à la base Access
    Set AccessCn = New ADODB.Connection
    AccessCnn.Open "provider=microsoft.jet.oledb.4.0; data source=" & maBase
 
    'Transfert les données d'Access vers Excel
    AccessCnn.Execute "SELECT * INTO [Excel 8.0;" & _
        "Database=" & NomClasseur & "].[" & maFeuille & "] FROM " & maTable, nbEnr
 
    AccessCnn.Close
    Set AccessCnn = Nothing
End Sub

Sub TransfertAccess_Vers_Excel()
    'Crée un nouveau classeur contenant une feuille nommée "NomFeuille".
    'La requête effectuée dans la table Access va être enregistrée dans cette feuille.
 
    Dim NomClasseur As String, maFeuille As String
    Dim maTable As String
    Dim nbEnr As Long
 
    NomClasseur = "C:\SauvegardeClasseur.xls"
    maFeuille = "NomFeuille"
    'Nom de la table Access
    maTable = "Table1"
 
    'Transfert les données d'Access vers Excel
    CurrentDb.Execute "SELECT * INTO [Excel 8.0;" & _
        "Database=" & NomClasseur & "].[" & maFeuille & "] FROM " & maTable, nbEnr
    CurrentDb.Close
End Sub