Attribute VB_Name = "modBABA" Option Compare Database Option Explicit Sub TransfererVersExcel() '--------------------------------------------------------------------------------------- ' CopyRight : Ce code est librement ditribuable, copiable et imprimable, sous la seule ' contrainte de laisser visible la totalité des commentaires identifiant ' l'auteur de ce code, ses coordonnées, et ce copyright, et ce, sans ' limitation de durée dans le temps. '--------------------------------------------------------------------------------------- ' Procedure : TransfererVersExcel ' Date : vendredi 04 janvier 2008 23:13 ' Auteur : Maxence Hubiche (mhubiche@club-internet.fr) '--------------------------------------------------------------------------------------- ' Dim objExcel As Object 'Variable pour l'objet Excel.Application Dim objClasseur As Object 'Variable pour l'objet Excel.WorkBook Dim lngCompteur As Long 'Variable de compteur des champs Dim strNomFichier As String 'Variable pour le nom du fichier Dim rstDatas As DAO.Recordset 'Variable pour le recordset Const xlUp As Long = &HFFFFEFBE 'Constante pour recréer xlUp (d'Excel) 'Définir le Recordset Set rstDatas = CurrentDb.OpenRecordset("qrySource", dbOpenSnapshot) 'Définir les objets Application et Classeur d'Excel Set objExcel = CreateObject("Excel.Application") Set objClasseur = objExcel.WorkBooks.Add() 'Faire la boucle jusqu'à ce qu'on arrive à la fin (EOF=EndOfFile) du Recordset Do Until rstDatas.EOF 'remplir les cellules avec les données With objClasseur.Worksheets(1).Range("A65536").End(xlUp) For lngCompteur = 0 To rstDatas.Fields.Count - 1 'les numéros d'Index des champs commencent à 0 .Offset(1, lngCompteur).Value = rstDatas.Fields(lngCompteur).Value Next End With rstDatas.MoveNext 'Passer à l'enregistrement suivant Loop 'Remplir les titres des colonnes For lngCompteur = 0 To rstDatas.Fields.Count - 1 'les numéros d'Index des champs commencent à 0 objClasseur.Worksheets(1).cells(1, lngCompteur + 1).Value = rstDatas.Fields(lngCompteur).Name Next 'Enregistrer le classeur strNomFichier = CurrentProject.Path & "\datas_" & Format(Now(), "yyyymmddhhnnss") & ".xls" objClasseur.saveas strNomFichier 'Tout fermer proprement objClasseur.Close objExcel.Quit Set objClasseur = Nothing Set objExcel = Nothing 'Afficher le classeur Shell "Excel.exe " & Chr(34) & strNomFichier & Chr(34) End Sub