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
| Private Sub CmdExportIFS_Click()
Dim Rec As DAO.Recordset
Dim RecI As DAO.Recordset
Dim RecA As DAO.Recordset
Dim RecE As DAO.Recordset
Dim StrSql As String
Dim Temps As Double
'Dim HrsIns As Long
StrPath = "\\10.0.1.83\commun\production\pointage atelier\export\"
StrPF = "EXPORT-BPMS-" & Format(Now, "ddmmyyyy")
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE TblExportIFS.* FROM TblExportIFS"
StrSql = "Select * From QryPointageBPMS WHERE QryPointageBPMS.podate>=#" & Format(Me.CtlDateDebut, "MM/DD/YYYY") & "#" & " AND QryPointageBPMS.podate<=#" & Format(Me.CtlDateFin + 1, "MM/DD/YYYY") & "#"
Set Rec = CurrentDb.OpenRecordset(StrSql)
Set RecI = CurrentDb.OpenRecordset("Select * From TblExportIFS")
While Not Rec.EOF
Set RecA = CurrentDb.OpenRecordset("Select acproject, acprojectbpms, acactivitybpms From TblActivity Where acactivity = " & Chr(34) & Rec!poactivity & Chr(34))
Set RecE = CurrentDb.OpenRecordset("Select empersid From TblEmploye Where emid = " & Rec!poemploye)
RecI.AddNew
RecI!employe = RecE!empersid
RecI!datpointage = Rec!podate
RecI!Project = RecA!acprojectbpms
RecI!activity = RecA!acactivitybpms
Temps = Rec!potemps / 60
RecI!duree = Replace(Temps, ",", ".")
RecI.Update
Rec.MoveNext
Wend
RecA.Close
RecI.Close
Rec.Close
RecE.Close
Set RecA = Nothing
Set RecI = Nothing
Set Rec = Nothing
Set RecE = Nothing
DoCmd.SetWarnings True
StrFile = StrPath & StrPF & ".csv"
DoCmd.TransferText acExportDelim, , "TblExportIFS", StrFile, True
On Error GoTo errHnd
Set xls = CreateObject("Excel.Application")
Set wk = xls.Workbooks.Open(StrFile)
Set ws = wk.Sheets("Sheet1-RH046-POINT")
ws.Activate
xls.Visible = True
Exit Sub
errHnd:
MsgBox "Erreur N° " & Err.Number & vbLf & Err.Description, , Err.Source
End Sub |
Partager