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
|
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, Optional ByVal Arg_Feuil As String, Optional ByVal Arg_entete As Boolean = True) As Object
'Déclarations
Dim I As Integer
Dim NbrChamps As Integer
Dim Entete As Integer
Dim ExcelApp As Object
Dim Excelsheet As Object
On Error GoTo fExportExcel_Err
If Arg_entete = True Then
Entete = 1
Else
Entete = 0
End If
'existance d'un fichier modèle
If Arg_Path & "" = "" Then
'pas de fichier model
Set ExcelApp = CreateObject("Excel.application").Workbooks.Add
For I = 1 To ExcelApp.worksheets.Count
If ExcelApp.worksheets(I).Name = Arg_Feuil Then
Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
Exit For
End If
Next
If I = ExcelApp.worksheets.Count + 1 Then
'le nom de feuille n'existe pas
Set Excelsheet = ExcelApp.worksheets(1)
End If
Else
'fichier modèle
Set ExcelApp = GetObject(Arg_Path)
For I = 1 To ExcelApp.worksheets.Count
If ExcelApp.worksheets(I).Name = Arg_Feuil Then
Set Excelsheet = ExcelApp.worksheets(Arg_Feuil)
Exit For
End If
Next
If I = ExcelApp.worksheets.Count + 1 Then
'le nom de feuille n'existe pas
Set Excelsheet = ExcelApp.worksheets(1)
End If
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
If Arg_entete = True Then
'Titre de colonne
For I = 0 To NbrChamps - 1
Excelsheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).Name
Next
End If
'copie des infos
Excelsheet.cells(Arg_Ligne + Entete, 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 + Entete, 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 - 1 + Entete, 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
.HorizontalAlignment = xlCenter
End With
If Arg_entete = True Then
With Excelsheet.Range(Excelsheet.cells(Arg_Ligne, Arg_Colonne), Excelsheet.cells(Arg_Ligne, Arg_Colonne + NbrChamps - 1))
.Interior.ColorIndex = 37
.Borders(xlEdgeBottom).Weight = xlMedium
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End If
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
Set Excelsheet = Nothing
End Function |
Partager