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
|
Function lf_Export2EXCEL(strSQL, Optional strNameFile As String)
On Error GoTo Err_lf_Export2EXCEL
' le sablier à On
DoCmd.Hourglass True
' vérifie que le fichier xls n'existe pas dans le chemin
If Len(strNameFile) = 0 Then strNameFile = "Export.xls"
strNameFile = Environ("USERPROFILE") & "\Mes Documents\" & strNameFile
If Len(Dir(strNameFile)) = 0 Then ' teste si le fichier existe
' crée la requete Temp avec la SQL select
CurrentDb.CreateQueryDef "Temp", strSQL
' Crée une sortie au format EXCEL
DoCmd.OutputTo acOutputQuery, "Temp", acFormatXLS, strNameFile, True
' supprime la query Temp
CurrentDb.QueryDefs.Delete "Temp"
Else ' le fichier existe on écrit à sa suite
Dim oExcel As Excel.Application ' l'application (évite l'erreur 462)
Dim oFeuille As Worksheet ' la feuille
Dim oWork As Workbook ' le workbook
Dim rst As Recordset ' le recordset ACCESS
Dim l As Long, i As Long, c As Long ' pour les déplacements dans la feuille
' ouvre instance Excel
Set oExcel = New Excel.Application
' feuille invisible
oExcel.Visible = False
' ouvre le fichier
Set oWork = oExcel.Workbooks.Open(strNameFile)
' active la 1ere feuille
Set oFeuille = oExcel.ActiveSheet
' recupère le n° de la dernière ligne rempli + 1
l = oFeuille.Cells.SpecialCells(xlCellTypeLastCell).Row
' ouvre la requete avec la SQL select
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot, dbForwardOnly)
' compte le nombre de champs à copier (initialise le compteur c )
c = rst.Fields.Count
' rajoute 1
If l > 1 Then l = l + 1
If MsgBox("Souhaitez-vous nettoyer le fichier EXCEL ?", vbYesNo, "Export EXCEL") = vbYes Then
' option nettoyage de feuille ouverte
oFeuille.Rows("1:65536").ClearContents
oFeuille.Rows("1:65536").ClearFormats
oFeuille.Rows("1:65536").Clear
' debut de fichier
l = 1
End If
If MsgBox("Souhaitez-vous insérer les noms des champs ?", vbYesNo, "Export EXCEL") = vbYes Then
' copie le nom des champs sur la première ligne
For i = 1 To c
oFeuille.Cells(l, i) = rst(i - 1).Properties("Caption")
oFeuille.Cells(l, i).Interior.Color = RGB(192, 192, 192) ' c'est le gris Excel
Next i ' traite chaque record
' ligne suivante
l = l + 1
End If
' copie le recordset
oFeuille.Cells(l, 1).CopyFromRecordset rst
'--------ACCESS-------------
' ferme le recordset libère l'objet
rst.Close
Set rst = Nothing
'--------EXCEL--------------
' ajuste les cellules
oFeuille.Rows.AutoFit
' rend la feuille visible
oExcel.Application.Visible = True
' active la fenetre principale EXCEL
oExcel.Windows(1).Visible = True
' sauve la feuille EXCEL
oWork.Close (True)
oExcel.Quit
' ferme l'objet xls
Set oFeuille = Nothing
Set oWork = Nothing
Set oExcel = Nothing
End If
Exit_lf_Export2EXCEL:
' le sablier à off
DoCmd.Hourglass False
Exit Function
Err_lf_Export2EXCEL:
If Err.Number = 3012 Then
CurrentDb.QueryDefs.Delete "Temp"
Resume
End If
If Err.Number = 3270 Then ' remplace le Caption par le Name
oFeuille.Cells(l, i) = rst(i - 1).Properties("Name")
Resume Next
End If
MsgBox Err.Number & " " & Err.Description, vbCritical, "Erreur"
'------- EXCEL ---------
oExcel.Visible = True
Set oFeuille = Nothing
Set oWork = Nothing
Set oExcel = Nothing
DoCmd.Hourglass False
End Function |
Probleme Export Excel Recherche Loufab
Répondre avec citation
)
pour en faire profiter tout le monde.
Partager