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
|
' Code de la fonction.
Private Sub ReportToXLS(stFile As String, thePath As String, stSource As String, theDb As Recordset)
On Error GoTo Err_ReportToXLS
Dim Abvr, stTarger, LeTmp, MoisDate, LaDate, XlsFile As String
LaDate = Now()
MoisDate = Format(LaDate, "yyyymm")
'Exécute le rapport avec le nom de chaque organisme
'Enregistre le rapport en XLS et sauve dans le F Orgscol\Rapports_NC
theDb.MoveFirst
With theDb
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
Abvr = theDb(0)
StTarget = stFile & Abvr & "_" & MoisDate & ".xls"
XlsFile = thePath & StTarget
DoCmd.OpenReport stSource, acPreview, , "[Organisme]='" & Abvr & "'", acHidden
DoCmd.OutputTo acOutputReport, stSource, acFormatXLS, XlsFile, False
.MoveNext
DoCmd.Close acReport, stSource
Wend
End If
.Close
End With
Exit_ReportTXLS:
Set theDb = Nothing
Exit Sub
Err_ReportToXLS:
MsgBox Err.Description
Resume Exit_ReportToXLS
End Sub |
Partager