1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
Private Sub excel_Click()
Dim xlApp As excel.Application
Dim xlSheet As excel.Worksheet
Dim xlBook As excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
Dim lien As String
t0 = Timer
Dim rec As Recordset
Set rec = CurrentDb.OpenRecordset("histotest", dbOpenSnapshot)
If Not rec.EOF Then
'Initialisations
Set xlApp = CreateObject("excel.Application")
Set xlBook = xlApp.Workbooks.Add
'Ajouter une feuille de calcul
Set xlSheet = xlBook.Worksheets.Add
xlSheet.Name = Date
' le titre
' écriture dans la cellule de ligne 1 et de colonne 1
xlSheet.Cells(1, 1) = "Export de la table historique"
' les entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlSheet.Cells(2, J + 1) = rec.Fields(J).Name
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(2, J + 1)
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
.AutoFormat
.AutoFilter
End With
Next J
' recopie des données à partir de la ligne 3
I = 3
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
' si c'est un Texte (dbText) nous insérons "'" pour
' qu'il soit reconnu par Excel comme du Texte
If rec.Fields(J).Type = dbText Then
xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
xlSheet.Cells(I, J + 1).AutoFormat
'Transforme le texte en hyperlien
If J = 8 Or J = 9 Or J = 10 Or J = 11 Then
lien = xlSheet.Cells(I, J + 1).Text
xlSheet.Cells(I, J + 1).Select
xlSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
lien _
, TextToDisplay:= _
lien
'Selection.Font.Underline = xlUnderlineStyleSingle
'Selection.Font.ColorIndex = 5
End If
Else
'si c'Est une date (dbDate) nous spécifions le format
'de date que excel doit prendre
If rec.Fields(J).Type = dbDate Then
xlSheet.Cells(I, J + 1).NumberFormat = "m/d/yyyy"
xlSheet.Cells(I, J + 1) = rec.Fields(J)
xlSheet.Cells(I, J + 1).AutoFormat
Else
xlSheet.Cells(I, J + 1) = rec.Fields(J)
xlSheet.Cells(I, J + 1).AutoFormat
End If
End If
Next J
I = I + 1
rec.MoveNext
Loop
' code de fermeture et libération des objets
On Error GoTo errexcel
Dim nomexcel As String
Dim dated As String
dated = Date
nomexcel = CurrentProject.Path & "\historique\Backuphistorique-" + dated + ".xls"
xlBook.SaveAs nomexcel
xlBook.Close
xlApp.Quit
rec.Close
Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
t1 = Timer
Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"
MsgBox "Table Historique Enregistrer"
DoCmd.OpenForm "menu principal", acDesign, , , , acHidden
Forms![menu principal]![excel].Caption = "Transfert Excel " + dated
DoCmd.Close acForm, "menu principal", acSaveYes
DoCmd.OpenForm "menu principal"
Else
MsgBox "Table Historique vide"
End If
Exit Sub
errexcel:
MsgBox "La table n'a pas été enregistrée"
xlBook.Close
xlApp.Quit
rec.Close
Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub |
