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 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
| Public Function CreeFichierProgramme(Mois As Integer, Annee As Integer)
Dim db As Database
Dim tblfich As recordset
Dim rqtfich As recordset
Dim datecourante As Date
Dim MyIndex As Index
Dim MyField As Field
Dim Compte As Integer
Dim num As String
Dim Table As TableDef
Dim EssaiRequete As QueryDef
Dim essai As recordset
Dim x As String
Dim ra As Integer
Compte = 10
Set db = CurrentDb
DoCmd.SetWarnings False
DoCmd.RunMacro ("CreationListeTournee")
DoCmd.SetWarnings True
db.TableDefs.Delete ("PRG")
Set Table = db.CreateTableDef("PRG")
Set MyField = Table.CreateField("Date", dbDate)
Table.Fields.Append MyField
Set MyIndex = Table.CreateIndex("Dates")
Set MyField = MyIndex.CreateField("Date")
With MyIndex
.Primary = True
End With
MyIndex.Fields.Append MyField
Table.Indexes.Append MyIndex
Set essai = db.OpenRecordset("ListeTournee", dbOpenTable)
If Not essai.EOF Then
essai.MoveFirst
End If
Do While Not essai.EOF
x = essai!No_Tournee
Set MyField = Table.CreateField(x, dbText)
MyField.Size = 6
Table.Fields.Append MyField
essai.MoveNext
Compte = Compte + 1
Loop
db.TableDefs.Append Table
Set tblfich = db.OpenRecordset("PRG", dbOpenTable)
'***Test si la table contient des enregistrements
If Not tblfich.EOF Then
tblfich.MoveFirst
End If
'***Efface chaque enregistrement de la table "Fichier Heure"
Do While Not tblfich.EOF
tblfich.Delete
tblfich.MoveNext
Loop
datecourante = CVDate("01-" & Mois & "-" & Annee)
'***Cree la colonne "date" du 1 à la fin du mois
Do While Month(datecourante) = Mois
tblfich.AddNew
tblfich!Date = datecourante
datecourante = DateAdd("d", 1, datecourante)
tblfich.Update
Loop
Set rqtfich = db.OpenRecordset("Base_Fiche", dbOpenDynaset)
tblfich.Index = "Dates"
If Not rqtfich.EOF Then
rqtfich.MoveFirst
End If
Do While Not rqtfich.EOF
tblfich.Seek "=", rqtfich!Date '***on pointe la date
If Not tblfich.NoMatch Then
tblfich.Edit
Select Case rqtfich!No_Tournee '***on select la tournée depuis 1
Case 1 To 119, 300 To 399, 3000 To 3110
x = rqtfich!No_Tournee '***on met ds la variable x le numéro de tournée
tblfich.Fields(x).Value = rqtfich!Nom_Raccourci '***on met dans le champ le nom de la personne
End Select
tblfich.Update
End If
rqtfich.MoveNext
Compte = Compte + 1
Loop
tblfich.Close
rqtfich.Close
Set Table = Nothing
Set MyField = Nothing
Set MyIndex = Nothing
essai.Close
'*Renommer les colonnes
Dim tb As TableDef
Dim fd As Field
Set db = CurrentDb
Set tb = db.TableDefs("PRG")
'Changement de la propriété nom du nouveau champ
Set essai = db.OpenRecordset("ListeTournee", dbOpenTable)
If Not essai.EOF Then
essai.MoveFirst
End If
Do While Not essai.EOF
x = essai!No_Tournee
Set fd = tb.Fields(x)
fd.Name = x & " " & "/" & " " & essai!Lettre_Tournee
tb.Fields.Refresh
essai.MoveNext
Compte = Compte + 1
Loop
Set fd = Nothing
'Changement de la propriété nom du nouveau champ
db.Close
End Function |
Partager