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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
| ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sub qui transfère les tableaux utilisés pour les calculs de PMI dans un workbook Excel
'qui sera sauvé dans le dossier \CalculPMI\ du CD correspondant
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub TransfertExcelDataPMI(ByVal idctrt As Integer)
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim i As Long, j As Long, n As Long, r As Long
Dim t0 As Long, t1 As Long
Dim intReponse As Integer
Dim oDb As DAO.Database
Dim oDbExcel As DAO.Database
Dim oTbl As DAO.TableDef
Dim rec As DAO.Recordset
Dim rec2 As DAO.Recordset
Dim rec3 As DAO.Recordset
Dim rec4 As DAO.Recordset
Dim oRst As DAO.Recordset
Dim Chemin As String, txt As String, stSQL As String, a As String
Dim strChemin As String
Dim sFichierExcel As String
Dim sql As String, sql2 As String
Dim bIsNull As Boolean
Dim vValue As Variant
Dim bFichierExiste As Boolean
' Gestion des erreurs
On Error GoTo Catch01
t0 = GetTickCount
n = 0 'nbr de table exportées
r = 0 'nbr d'enregistrements total exportés
Chemin = ""
strChemin = CurrentProject.Path
sFichierExcel = strChemin & "\seed_graph2.xlsx"
Set oDb = CurrentDb
'Ouvre un recordset sur la table DataCollect pour le numéro de CD en cours
sql = "SELECT * from DataCollect WHERE NumCD = " & idctrt
Set oRst = oDb.OpenRecordset(sql, dbOpenDynaset)
oRst.MoveLast
oRst.MoveFirst
DoCmd.Hourglass True
'Initialisations
On Error Resume Next ' instruction pour ignorer l'erreur qui pourrait se déclencher sur la ligne suivante
Set xlApp = GetObject(, "Excel.Application") ' on récupère l'instance Excel ouverte : si pas d'instance la variable est à nothing
On Error GoTo Catch01 ' reprend la gestion d'erreur normale en annulant l'effet de l'instruction On error resume next
If xlApp Is Nothing Then ' si pas d'instance d'Excel de créée
Set xlApp = CreateObject("Excel.Application") ' on crée une nouvelle instance
End If
'on teste si le fichier seed_graph existe et s'il est disponible = pas ouvert déjà
bFichierExiste = False
If Len(Dir(sFichierExcel, vbNormal)) > 0 Then
bFichierExiste = True
' Si fichier ouvert, afficher un message et sortir
If IsFileOpen(sFichierExcel) Then
MsgBox "Veuillez fermer le fichier '" & sFichierExcel & "' SVP"
Exit Sub
End If
End If
If bFichierExiste Then ' Si le fichier existe on l'ouvre
Set xlBook = xlApp.Workbooks.Open(sFichierExcel)
Else ' Sinon on le crée et on aura un fichier sans feuille avec graphique
Set xlBook = xlApp.Workbooks.ADD
End If
' définir ici le chemin vers le dossier sur le réseau et remplacer Application.CurrentProject.Path par le chemin choisi au début
'si pas de chemin choisi dans la table DataCollect, demander à le définir et sauver cela dans le champ adéquat "LinkRapport" de la table "DataCollect
If Len(Trim(oRst.Fields("LinkRapport"))) > 0 Or Not IsNull(oRst.Fields("LinkRapport")) Then 'on vérifie que le champ contient quelque chose
Chemin = Trim(Replace(oRst.Fields("LinkRapport"), "#", "")) & "\CalculPMI"
If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin 'est-ce que le chemin existe (jusqu'au dossier CalculPMI)?non? alors on le crèe
Else 'le oRst.Fields("LinkRapport") est donc vide ou null
'on doit récupérer ici le chemin a parcourir pour y créer le dossier CalculPMI
Chemin = OuvrirUnFichier(Application.hWndAccessApp, "Sélectionner le dossier du cas contenant les infos ", 1)
' si la boite renvoie une adresse non nulle
If Len(Chemin) > 0 Then
i = InStrRev(Chemin, Chr(92), , vbTextCompare)
'MsgBox Mid(Chemin, 1, i - 1)
oRst.Edit
oRst.Fields("LinkRapport").value = Mid(Chemin, 1, i - 1)
oRst.Update
Chemin = Mid(Chemin, 1, i - 1)
End If
Chemin = Chemin & "\CalculPMI"
MkDir Chemin 'on peut maintenant créer le chemin et le dossier de destination
End If
Chemin = Chemin & "\CD" & CStr(idctrt) & "-PMI-" & Format(Now, "dd_mm_yyyy") & ".xlsx" 'on prépare le string contenant le chemin complet avec le nom du fichier qu'on va créer
If Dir(Chemin) <> "" Then
intReponse = MsgBox("Le fichier " & Chemin & " existe déjà, à l'emplacement spécifié. Désirez-vous le remplacer?", vbYesNoCancel + vbCritical + vbDefaultButton3, "Attention !")
Select Case intReponse
Case vbNo
'DoCmd.Close acForm, "ExportCDExcell"
MsgBox "L'exportation des données a été annulée", vbCritical, "Attention !"
GoTo onquitte
Case vbCancel
'DoCmd.Close acForm, "ExportCDExcell"
MsgBox "L'exportation des données a été annulée", vbCritical, "Attention !"
GoTo onquitte
Case Else 'on continue le déroulement normal = vbYes
Kill Chemin 'on supprime le fichier existant
xlBook.SaveAs (Chemin) 'et on en crèe un nouveau avec le même nom
End Select
intReponse = 0
Else
xlBook.SaveAs (Chemin) ' create the workbook '
End If
For Each oTbl In oDb.TableDefs
If oTbl.Name Like "Temp*" Then
Set rec = oDb.OpenRecordset(oTbl.Name, dbOpenSnapshot)
rec.MoveLast
rec.MoveFirst
'Ajouter une feuille de calcul
Set xlSheet = xlBook.Worksheets.ADD
xlSheet.Name = Right(CStr(oTbl.Name), Len(oTbl.Name) - 5) 'on garde que les caractères après Tempx pour nommer les feuilles de calculs
' le titre
' écriture dans la cellule de ligne 1 et de colonne 1
xlSheet.Cells(1, 1) = "Export de la table Access " & oTbl.Name & " concernant le CD" & idctrt
' on inscrit sur la ligne 2 les paramètres retenus pour l'ensemble des calculs
Select Case intdrpb_interpol
Case 0
a = "Lagrange"
Case 1
a = "linéaire"
Case 2
a = "spline"
Case 3
a = "cubic-splines"
Case Else
a = "?"
End Select
xlSheet.Cells(2, 1) = "Méthode d'interpolation choisie: " & a
xlSheet.Cells(2, 5) = "La date d'émergence utilisée est celle où l'on a un total de " & CStr(startnbremerge) & " individu(s) émergé(s) depuis le début (pour chaque espèce)"
' les entetes des champs sont sur la ligne 3
' .Fields(Index).Name renvoie le nom du champ
For j = 0 To rec.Fields.count - 1
xlSheet.Cells(3, j + 1) = rec.Fields(j).Name
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(3, j + 1)
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next j
' recopie des données à partir de la ligne 4
i = 4
r = 0
Do While Not rec.EOF
r = r + 1 'compteur enregistrements totaux exportés
For j = 0 To rec.Fields.count - 1
' si on est dans le champ station_number, on va chercher le code de la station pour la traduire en mots utilisables
If rec.Fields(j).Name = "station_number" And Not IsNull(rec.Fields(j)) Then
xlSheet.Cells(1, 6) = "Station (" & rec.Fields(j) & ") = " & DLookup("Nom", "tblStations_Météo", "Code = " & rec.Fields(j))
End If
' .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
Select Case rec.Fields(j).type
Case dbText
xlSheet.Cells(i, j + 1) = Chr(39) & rec.Fields(j)
Case dbDate
xlSheet.Cells(i, j + 1) = DateSerial(Year(rec.Fields(j)), Month(rec.Fields(j)), Day(rec.Fields(j))) + TimeSerial(Hour(rec.Fields(j)), 0, 0) ' Format(rec.Fields(j).value, "dd/mm/yyyy hh:nn:ss")
Case Else
xlSheet.Cells(i, j + 1) = rec.Fields(j)
End Select
Next j
i = i + 1
rec.MoveNext
Loop
n = n + 1 'compteur nbr tables totales exportées
Else
GoTo LastLine
End If
rec.Close
LastLine:
Next oTbl
sql = ""
' si bFichierExiste= true, on va maintenant exporter dans la feuille graphique du fichier xlsx généré
' les colonnes adéquates pour alimenter le graphique existant
' en fait c'est la table Temp6StationExtrap à laquelle on a retiré certains champs
sql2 = "SELECT * from Temp6StationExtrap"
Set rec2 = oDb.OpenRecordset(sql2, dbOpenDynaset)
rec2.MoveLast
rec2.MoveFirst
'chaine sql qui reprendra uniquement les champs nécessaire de la table ' on essaie en enlevant les Temp6StationExtrap. devant les noms des champs
sql = "SELECT [DateFull], " & _
"[relative_humidity_under_shelter], " & _
"[precipitation_duration], " & _
"[precipitation_quantity], " & _
"[" & rec2.Fields(6).Name & "], " & _
"[TempExtrapTE], "
'on y rajoute les champs correspondants aux espèces présentes, concaténés l'un après l'autre,
'ca commence à partir de la colonne n°11 de la table d'origine
For j = 11 To rec2.Fields.count - 1
sql = sql & "[" & Trim(rec2.Fields(j).Name) & "], "
Next j
'et on fini la chaine
sql = Left(sql, Len(sql) - 2) & " FROM Temp6StationExtrap"
'on ferme ce recordset pour pouvoir réutiliser la variable
'ouverture du recordset avec juste les champs retenus
Set rec3 = oDb.OpenRecordset(sql, dbOpenDynaset)
rec3.MoveLast
rec3.MoveFirst
'dans le rec, pour chaque espèce, on va garder la première et la dernière valeur non nulle
'ca servira a illustrer les espèces sur le graphe
'le premier champs correspondant à une espèce commence à la colonne 7 (= fields(6))
For j = 6 To rec3.Fields.count - 1
bIsNull = True
vValue = Null
With rec3
Do While Not .EOF
If IsNull(.Fields(j)) Then '--- actuel Null
bIsNull = True
If IsNull(vValue) Then
'--- continuer (rien à changer)
Else
'--- remettre valeur sur enregistrement précédent
'--- (Nullé alors qu'il n'aurait pas du l'être)
.MovePrevious
.Edit
.Fields(j).value = 30 'ou vValue si on garde la valeur d'origine
.Update
'--- revenir sur enregistrement en cours
vValue = Null
.MoveNext
End If
Else '--- actuel non Null
If bIsNull Then '--- champ précédent vide
bIsNull = False
'--- et continuer (rien à changer)
.Edit
.Fields(j).value = 30 ' ou vValue si on garde la valeur d'origine
.Update
Else '--- champ précédent non vide
vValue = 30 'ou .Fields(j).value si on garde la valeur d'origine
.Edit
.Fields(j).value = Null
.Update
End If
End If
.MoveNext
Loop
End With
rec3.MoveFirst
Next j
'on sauve et ferme le classeur excel
xlBook.Close True ' sauve et ferme le workbook
If TestExistenceFeuille("graphique", Chemin, xlApp) Then
'on continue
Set xlBook = xlApp.Workbooks.Open(Chemin) 'on réouvre le workbook
Set xlSheet = xlBook.Sheets("graphique") 'on sélectionne la feuille
Else
MsgBox "La feuille n'existe pas"
GoTo quitpourtest
End If
' les entetes des champs sont sur la ligne 3
For j = 0 To rec3.Fields.count - 1
xlSheet.Cells(3, j + 1).value = rec3.Fields(j).Name
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(3, j + 1)
.Interior.ColorIndex = 15
'.Font.Bold = True
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next j
xlSheet.Cells(4, 1).CopyFromRecordset rec3 ' copie du recordset à partir de la cellule (4,1)= "A4" de la feuille
rec3.Close
quitpourtest:
xlBook.Close True ' sauve le workbook xlBook.Save ' sauve le workbook
xlApp.Quit
DoEvents
onquitte:
DoCmd.Hourglass False
Set rec = Nothing
rec2.Close
Set rec2 = Nothing
Set rec3 = Nothing
Set rec4 = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
MsgBox "Les données ont été sauvées dans le fichier : " & Chemin
Set oTbl = Nothing
Set oDbExcel = Nothing
Set oDb = Nothing
'' MonRubanEntomo.ActivateTab "NewDossier"
'Stop_Timer (1)
Exit Sub
Catch01:
Select Case err.Number
Case 0
GoTo onquitte
Case 2220
'Cas d'un emplacement non valide du fichier
MsgBox "Le fichier n'a pas été trouvé à l'emplacement indiqué : " & vbCrLf & _
Chemin, vbCritical + vbOKOnly, "Export Excel"
Exit Sub
Case Else
' tout autre cas d'erreur
MsgBox "Erreur inattendue : " & err.Number & vbCrLf & err.Description, vbCritical + vbOKOnly, "Export Excel"
End Select
err.Clear
GoTo onquitte
End Sub |
Création de graphique au départ d'une table
) sur le processus et surtout sur le code VBA que je dois mettre en oeuvre.... Cela peut être un graphique dans Access (et que l'utilisateur pourra copier-coller) ou dans excel (piloté depuis Access)... Mais j'avoue que je préfère la première solution.
Répondre avec citation
Envoyé par USer
ET avant de travailler sur la feuille cible, j'ai préféré sauver le classeur puis le réouvrir. En effet, comme il est possible qu'il n'y ai pas de feuille cible, il fallait tester cela.
Partager