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 |
