[En cours]Exporter des données vers Excel [Sources]

[Muhad'hib]

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 :

Code :

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

Les arguments :
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 :

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 :

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 !

[STEF_1]

Salut Muhad'hib


Pour la copie de tes info dans excel, pourquoi ne pas utiliser la fonction

Code :

1
2
 
XlSheet.Range("A2").CopyFromRecordset RsExport

ou XlSheet est un object Excel.Worksheet
et RsExport un Recordset DAO

Cela t'évirerait d'avoir a balayer ta table, et quelques lignes de code

@+

[Muhad'hib]

Salut,

Ben pourquoi j'utilise pas cette fonction : c'est simple, c'est parceque je la connaissais pas

MERCI STEPH_1 !

La fonction devient donc :

Code :

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
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
 
'existance 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
 
'existance 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
        ExcelSheet.cells(Arg_Ligne + 1, Arg_Colonne).CopyFromRecordset Arg_Rs
        'mise en forme si arg_cadre = true
            If Arg_MEF = True Then
                'datage
                    With ExcelSheet.cells(Arg_Rs.RecordCount + Arg_Ligne + 1, NbrChamps - 1 + Arg_Colonne)
                        .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 + Arg_Rs.RecordCount, Arg_Colonne + NbrChamps - 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 + NbrChamps - 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 inatendue est apparut 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

A+ et encore merci.