Bonjour a tous,
J'ai fais une fonction que j'utilise dans mes appli ayant beaucoup de rapports fait sur des feuilles Excel. Je me dis qu'elle pourrait être utile à d'autres (telquelle ou pour s'en inspirer). Ce n'est ni trés original, ni trés complexe, mais bon ...
Titre : Générer automatiquement des rapports sur Excel
Auteur : Muhad'hib
Intérêt : Ne pas écrire n fois le même genre de code quand on a plusieurs rapports dans la même appli
Utilisée sur ACCESS 2000
Les références utilisée :
Visual Basic for Applications
Micrsoft Access 9.0 Object Library
OLE Automation
Microsoft Activex Data Object Library
Microsoft DAO 3.6 Object Library
Les constantes :
Je déclares une série de constante pour garder la syntaxe d'Excel :
Les arguments :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 Global Const xlDownThenOver = 1 Global Const xlLandscape = 2 Global Const xlPaperA4 = 9 Global Const xlPrintNoComments = -4142 Global Const xlDiagonalUp = 6 Global Const xlDiagonalDown = 5 Global Const xlEdgeLeft = 7 Global Const xlContinuous = 1 Global Const xlMedium = -4138 Global Const xlAutomatic = -4105 Global Const xlEdgeTop = 8 Global Const xlEdgeBottom = 9 Global Const xlEdgeRight = 10 Global Const xlHairline = 1 Global Const xlInsideVertical = 11 Global Const xlInsideHorizontal = 12 Global Const xlNone = -4142 Global Const xlThin = 2 Global Const xlWorksheet = -4167 Global Const xlRight = -4152
Arg_Path : String donnant chemin (path + nom de fichier + extension) du fichier Excel servant éventuellement de "modèle" pour le rapport.
Arg_Rs : DAO.Recordset contenant les données à intégrer dans le rapport.
Arg_MEF : Boolean indiquant si oui ou non on fait une petite mise en forme des données.
Arg_Ligne : Integer indiquant le N° de ligne où coller les données.
Arg_Colonne : Integer indiquant le N° de colonne où coller les données.
La fonction :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Public Function fExportExcel(ByVal Arg_Path As String, ByVal Arg_Rs As DAO.Recordset, Optional ByVal Arg_MEF As Boolean = False, Optional ByVal Arg_Ligne As Integer = 1, Optional ByVal Arg_Colonne As Integer = 1) As Object 'Déclarations Dim I As Integer Dim J As Integer Dim NbrChamps As Integer Dim ExcelApp As Object Dim ExcelSheet As Object On Error GoTo fExportExcel_Err 'existence d'un fichier modèle If Arg_Path & "" = "" Then 'pas de fichier model Set ExcelApp = CreateObject("Excel.application").Workbooks.Add Set ExcelSheet = ExcelApp.worksheets(1) Else 'fichier modèle Set ExcelApp = GetObject(Arg_Path) Set ExcelSheet = ExcelApp.worksheets(1) End If ExcelApp.windows(1).Visible = True 'ExcelApp.Application.Visible = True 'existence des données If Not (Arg_Rs.BOF = True And Arg_Rs.EOF = True) Then 'il y a des données à exporter Arg_Rs.MoveLast Arg_Rs.MoveFirst NbrChamps = Arg_Rs.Fields.Count 'Titre de colonne For I = 0 To NbrChamps - 1 ExcelSheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).Name Next 'copie des infos For J = 0 To Arg_Rs.RecordCount - 1 'fait défillé les enregistrements For I = 0 To NbrChamps - 1 'fait défiller les champs ExcelSheet.cells(J + Arg_Ligne + 1, I + Arg_Colonne) = Arg_Rs(I) Next Arg_Rs.MoveNext Next 'mise en forme si arg_cadre = true If Arg_MEF = True Then 'datage With ExcelSheet.cells(J + Arg_Ligne + 1, I + Arg_Colonne - 1) .Value = "'" & Format(Now, "dd/mm/yyyy") .Font.Size = 6 .HorizontalAlignment = xlRight End With 'cadre + couleur des titres 'with = la zone tableau With ExcelSheet.Range(ExcelSheet.cells(Arg_Ligne, Arg_Colonne), ExcelSheet.cells(Arg_Ligne + J, Arg_Colonne + I - 1)) .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium End With With ExcelSheet.Range(ExcelSheet.cells(Arg_Ligne, Arg_Colonne), ExcelSheet.cells(Arg_Ligne, Arg_Colonne + I - 1)) .Interior.ColorIndex = 37 .Borders(xlEdgeBottom).Weight = xlMedium End With End If End If GoTo fExportExcel_Exit 'gestion des erreurs fExportExcel_Err: MsgBox "Une erreur inattendue est apparue dans la fonction fExportExcel. L'erreur N° " & Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", vbOKOnly + vbCritical, "Erreur inattendue !" Set fExportExcel = Nothing Exit Function 'Sortie fExportExcel_Exit: Set fExportExcel = ExcelApp Set ExcelApp = Nothing End Function
Et voici à quoi peut ressembler l'utilisation de la fonction :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Sub Test() Dim Chemin As String Dim Rs As DAO.Recordset Dim Excl As Object On Error GoTo Test_Err Set Rs = CurrentDb.OpenRecordset("T_Test", dbOpenDynaset) 'Debug.Print fNbrField(Rs) 'Chemin = "c:\test.xls" Chemin = "" Set Excl = fExportExcel(Chemin, Rs, True, 11, 2) If Excl.Name <> "" Then 'Autres manipulations du classeur (titre, mise en forme, auteur, ..) 'par exemple rendre le doc visible : Excl.Application.Visible = True Excl.saveas "c:\test_bis.xls" Excl.Application.Quit Set Excl = Nothing End If Exit Sub Test_Err: If Err.Number <> 91 Then MsgBox "Une erreur inattendue est apparue dans la fonction Test. L'erreur N° " & Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", vbOKOnly + vbCritical, "Erreur inattendue !" End If Set Excl = Nothing End Sub
Merci à Cafeine pour son Tuto " Communication entre Access et Excel" !
Les commentaires, remarques et améliorations sont les bienvenues !
Partager