Function ExportSynthèse()
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim t0 As Long, t1 As Long
t0 = Timer
folder = "M:\1.Outils de Suivi\test\"
ficname = InputBox("Sous quel nom sauvegarder le fichier de synthèse?", , "Synthèse")
alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Call OuvertureMaquette(xlApp, xlBook, folder)
'Call ExportDatas(alphabet, xlApp, xlBook, "INFO_FREQUENCY")
'Call ExportDatas(alphabet, xlApp, xlBook, "INFO_CONTACT")
Call ExportDatas(alphabet, xlApp, xlBook, "RQ_ORIGINE_PB")
Call Sauvegarde(xlApp, xlBook, xlSheet, folder, ficname)
t1 = Timer
MsgBox "Traitement terminé en " & Format(t1 - t0, "0") & " secondes." & Chr(13) & Chr(13) & "Le fichier est disponible sous " & folder
End Function
Function OuvertureMaquette(xlApp, xlBook, folder)
'Initialisations
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Ouverture de la maquette
Set xlBook = xlApp.Workbooks.Open(folder & "Maquette.xls")
End Function
Function ExportDatas(alphabet, xlApp, xlBook, Données)
Dim I As Long, J As Long
Dim rec As Recordset
Dim lig As Long, col As Long
'Définition de la table utilisé
Set rec = CurrentDb.OpenRecordset(Données, dbOpenSnapshot)
'Sélection de la zone correspondante dans Excel
xlApp.Application.Goto Reference:=Données
xlApp.ActiveCell.Select
lig = xlApp.ActiveCell.Row
col = xlApp.ActiveCell.Column
'Mention de ce qui a été exporté
xlApp.Cells(lig - 1, col) = "Export de " & Données
'Insertion des entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlApp.Cells(lig, col + J) = rec.Fields(J).Name
Next J
'Copie des données à partir de la ligne 3
I = lig + 1
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
If rec.Fields(J).Type = dbText Then
xlApp.Cells(I, col + J).NumberFormat = "@"
xlApp.Cells(I, col + J) = rec.Fields(J)
'xlApp.Cells(I, J + 1) = "'" & rec.Fields(J)
Else
xlApp.Cells(I, col + J) = rec.Fields(J)
End If
Next J
I = I + 1
rec.MoveNext
Loop
'redéfinition de la zone sous Excel
If col > 26 Then
firstcol = Mid(alphabet, Int(col / 26), 1) & Mid(alphabet, col - ((Int(col / 26)) * 26), 1)
Else
firstcol = Mid(alphabet, col, 1)
End If
If (col + J - 1) > 26 Then
lastcol = Mid(alphabet, Int((col + J - 1) / 26), 1) & Mid(alphabet, (col + J - 1) - ((Int((col + J - 1) / 26)) * 26), 1)
Else
lastcol = Mid(alphabet, col + J - 1, 1)
End If
zone = xlApp.ActiveSheet.Name & "!$" & firstcol & "$" & lig & ":$" & lastcol & "$" & I - 1
'zone = "=" & xlApp.ActiveSheet.Name & "!R" & lig & "C" & col & ":R" & I - 1 & "C" & col + J - 1
xlApp.ActiveWorkbook.Names.Item(Données).Delete
xlApp.ActiveWorkbook.Names.Add Name:=Données, RefersToR1C1:="=" & zone
rec.Close
Set rec = Nothing
End Function
Function Sauvegarde(xlApp, xlBook, xlSheet, folder, ficname)
' code de fermeture et libération des objets
t1 = Timer
xlBook.SaveAs folder & ficname & ".xls"
'comment fermer un classeur en enregistrant automatiquement à la sortie
'xlBook.Close (True) 'on dit qu'on enregistre les modifs du fichiers
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
't1 = Timer
'MsgBox I & " enregistrements", Format(t1 - t0, "0") & " secondes"
End Function