I. Le contexte de l'exemple▲
Il s'agit d'une entreprise qui fonctionne avec du personnel bénévole.
Deux personnes doivent assurer une permanence pour quatre plages horaires sept jours sur sept soit 06-09 ; 09-12 ; 12-15 et 15-18.
Le but est de disposer d'un programme qui établit le rôle de garde en répartissant les appels de volontaires de manière équitable : c'est-à-dire sans donner systématiquement la priorité à ceux qui sont souvent disponibles et négliger l'offre de celui qui ne peut venir qu'un jour, une semaine sur deux.
I-A. Chaque volontaire a proposé ses disponibilités, ainsi que ses desiderata▲
Deux exemples pour être concret :
|
|
Note pour mes amis hexagonaux |
 |
Autre point de vocabulaire |
Ces données ne sont pas figées : ce sont celles en vigueur au moment où on lance le programme qui va établir le rôle de garde pour une période à venir.
Le dépendant doit calquer son offre sur celle de son obligé.
Les deux doivent commencer et terminer aux mêmes pauses, les jours où ils viennent ensemble.
Ces deux contraintes peuvent être différentes, mais, si à cause de ces contraintes,
l'obligé n'est pas sélectionné, la candidature du dépendant ne sera pas retenue.
Le dépendant ne peut exprimer cette contrainte : c'est celle de l'obligé qui sera prise en considération (pour garantir qu'ils terminent leur prestation ensemble). Cette case s'allume en rouge si elle est remplie.
Dans cet exemple, si Maigret est choisi un jeudi, il viendra seul.
Dans la réalité, il se pourrait qu'il n'y ait pas de volontaire disponible pour une pause.
Dans tVolontaires, nous avons ajouté deux volontaires fictifs (Joker) qui seront alors élus à coup sûr : ils sont « candidats » pour toutes les pauses et sans restriction :
Quand un Joker est élu, c'est qu'il y a un problème d'effectif à régler.
Nous verrons plus loin qu'il s'affichera en rouge pour attirer l'attention de l'utilisateur sur cette lacune à combler.
I-B. Ce que l'on veut réaliser▲
En un clic, obtenir un horaire des prestations futures.
II. Le raisonnement pour affecter les tâches « équitablement »▲
Pour chaque volontaire, on calcule un rang de priorité.
C'est la somme
- du nombre des pauses pour lesquelles il est candidat et
- le nombre de pauses pour lesquelles il a effectivement été sélectionné dans le passé.
Donc plus un candidat propose ses services et plus il a été choisi pour prester, plus son rang est élevé.
Pour choisir l'effectif d'une pause, le programme d'affectation donne la priorité aux deux candidats qui ont le plus petit rang : on privilégie ainsi ceux qui ont été moins souvent élus !
Si un élu est aussi candidat pour la pause suivante de la journée, il devient prioritaire pour celle-ci. (Ceux qui sont déjà sur place et qui sont candidats sont élus d'office.)
Le programme vérifie que les volontaires qui dépendent d'un autre (Simenon/Maigret) sont élus simultanément et que deux exclus mutuels (Hemingway/Arnothy) ne forment pas la paire retenue.
III. Le modèle de données▲
Quatre tables :
Les colonnes Dim06-09 => Sam15-18 sont de type booléen.
Les colonnes Rang et RangJour sont calculées dynamiquement, elles servent à gérer l'ordre de priorité lors de l'attribution des rôles. Idem pour MotifRejet qui mentionnera pourquoi le candidat n'a pas été retenu.
IV. Les références utiles▲
V. Le formulaire fVolontaires▲
Cette zone de liste permet de choisir le volontaire à afficher.
Le code associé à l'événement après mise à jour :
Public Sub cboVolontaire_AfterUpdate()
'On cherche l'enregistrement qui contient cette valeur
Me.Recordset.FindFirst "tVolontairesPK =" & Me.cboVolontaire
End SubSi l'utilisateur introduit un nom qui ne fait pas partie de la liste, ce message s'affiche :
Voici le code qui est exécuté lorsque le choix n'est pas dans la liste :
Private Sub cboVolontaire_NotInList(NewData As String, Response As Integer)
MsgBox NewData & " ? Mais ce volontaire n'existe pas !" & vbCrLf & "Veuillez choisir une personne de la liste.", vbExclamation
Me.cboVolontaire.Undo
Response = acDataErrContinue
End Sub Ce contrôle est indépendant, sa source ="(" & StatutDuCandidat([txttVolontairesPK]) & ")"
fait appel à la fonction StatutDuCandidat pour afficher s'il s'agit d'un volontaire « ordinaire », « dépendant » ou « obligé ».
Public Function StatutDuCandidat(idCandidat As Long) As String
Dim LngPartenaire As Long
LngPartenaire = Nz(DLookup("tVolontairesFK", "tCoVolObli", "VolObliFK=" & idCandidat), 0)
If LngPartenaire <> 0 Then
StatutDuCandidat = "Obligé"
Else
LngPartenaire = Nz(DLookup("VolObliFK", "tCoVolObli", "tVolontairesFK=" & idCandidat), 0)
If LngPartenaire <> 0 Then
StatutDuCandidat = "Dépendant"
Else
StatutDuCandidat = "Ordinaire"
End If
End If
End FunctionIl est affecté d'une mise en forme conditionnelle :
Il s'agit d'un sous-formulaire fils :
La zone de liste propose les volontaires autres que lui-même et les jokers :
Il s'agit d'un sous-formulaire fils :
La zone de liste propose les volontaires autres que lui-même, les jokers et ceux qu'il a désignés comme covolontaire obligé :
Ne pas oublier d'actualiser le contenu des zones de liste
- à chaque lecture d'un enregistrement
Private Sub Form_Current()
Me.cboVolontaire = Null
Me.CTNRsfCoVolExclus.Form.cboCovolExclu.RowSource = _
Me.CTNRsfCoVolExclus.Form.cboCovolExclu.RowSource
Me.CTNRsfCoVolObli.Form.cboCovolObli.RowSource = _
Me.CTNRsfCoVolObli.Form.cboCovolObli.RowSource
End Sub- quand on modifie le contenu de cboCovolObli dans le sous-formulairesfCoVolObli
Private Sub cboCovolObli_AfterUpdate()
Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource = _
Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource = _
Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource
End Sub
Un clic sur l'un de ces boutons remplit ou vide toutes les cases à cocher.
Private Sub BtTout_Click()
Dim ctl As Control
For Each ctl In Me.Controls
If ctl.Name Like "cc*" Then ctl = True
Next ctl
End Sub
Private Sub BtRien_Click()
Dim ctl As Control
For Each ctl In Me.Controls
If ctl.Name Like "cc*" Then ctl = False
Next ctl
End SubVI. Le formulaire fAffectations▲
VI-A. Présentation▲
Les volontaires « ordinaires » s'affichent en vert : 
Les « dépendants » en bleu clair : 
Les « obligés » en bleu foncé : 
|
|
Lorsqu'un « dépendant » est sélectionné, son obligé l'accompagne nécessairement |
.
si le dépendant n'est pas disponible à ce moment.
.Ces couleurs résultent de la mise en forme conditionnelle du contrôle txtRetenu dans le sous-formulaire sfPause :
L'espace réservé à chaque pause permet de voir les deux volontaires qui ont été retenus.
Dans chacune des 28 pauses affichées, un clic sur le bouton 
permet d'afficher les candidats non retenus ainsi que le motif de non-sélection :
Le formulaire fNonElus vient s'afficher juste en dessous du bouton cliqué.
On utilise pour cela la technique mise au point par Arkham46 dans cette contribution.
VI-B. Particularités techniques▲
C'est un formulaire père indépendant (sans source)
qui contient 28 fois le même sous-formulaire fils sfPause (4 pauses X 7 jours).
Chacun d'eux va afficher la portion ad hoc de la table tAffectation.
Par exemple celui marqué 
est dans le conteneur CTNR12 :
La coordination père/fils s'opère
- pour le fils : sur le contenu des colonnes AffDate et AffPause ;
- pour le père : les contrôles [txtDate1] 
et [txt09-12] 
.
Les 28 conteneurs sont construits sur le même moule : CTNRij
- avec i qui indique la ligne (les 7 jours)
- avec j qui indique la pause (1 = 06-09, ? , 4 = 15-18).
Les contrôles [txtDate1] à [txtDate7] ont une source qui se réfère au contenu de [txtDateDepart] 
, le seul contrôle auquel l'utilisateur a accès.
Ainsi, [txtDate1] = [txtDateDepart] + 0, ? , [txtDate4] = [txtDateDepart] + 3, ? , [txtDate7] = [txtDateDepart] + 6.
C'est donc la mise à jour d'un seul contrôle [txtDateDepart] qui déclenche l'affichage des 28 équipes sélectionnées.
Par défaut, c'est le lundi de la semaine actuellement en cours qui s'affiche :
Public Function LundiPasse() As Date
LundiPasse = Date
If Format(LundiPasse, "dddd") <> "lundi" Then
Do Until Format(LundiPasse, "dddd") = "lundi"
LundiPasse = LundiPasse - 1
Loop
End If
End FunctionLes deux boutons 
servent à ajouter ou retrancher 7 jours à la date saisie dans [txtDateDepart].
Le code du clic sur le bouton 
d'un des 28 sous-formulaires sfPause mérite le détour (une des acrobaties annoncées dans le synopsis) :
2.
3.
4.
5.
6.
7.
8.
9.
Private Sub btNonElus_Click()
Dim strRef() As String
strRef = Split(Me.Parent.ActiveControl.LinkMasterFields, ";")
gvDetailDate = Me.Parent(strRef(0))
gvDetailPause = Me.Parent(strRef(1))
If CurrentProject.AllForms("fNonElus").IsLoaded Then DoCmd.Close acForm, "fNonElus"
DoCmd.OpenForm "fNonElus", , , , , acHidden
PositionForm Forms("fNonElus"), Me.btNonElus
End Sub
Commentaires du code
2 : on définit une variable tableau pour utiliser la fonction Split().
3 : si l'utilisateur a cliqué sur le bouton de la 2e ligne, 2e colonne, alors Me.Parent.ActiveControl.LinkMasterFields correspond au texte marqué d'une flèche
Donc Ref(0) reçoit « [txtDate2] » et Ref(1) reçoit « [txt09-12] ».
4-5 : et Me.Parent(Ref(0)) vaut « 23/02/2016 » ; Me.Parent(Ref(1)) vaut « 09-12 ».
Ces deux valeurs sont mémorisées dans deux variables globales (gvDetailDate et gvDetailPause).
6-8 : on ouvre le formulaire fNonElus qui a cette requête comme source :
VII. Le formulaire fAffecter▲
Il permet d'établir le rôle des volontaires en renseignant une date à venir et une durée.
Un clic sur le bouton 
aura pour effet :
- de supprimer dans la table tAffectations tous les enregistrements (éventuels) à partir de la date mentionnée ;
- de « recalculer » les affectations pour la période en fonction des desiderata actuels des volontaires ;
- d'afficher le formulaire fAffectations à partir de la date.
Option Compare Database
Option Explicit
Private Sub btGenerer_Click()
Dim I As Integer
'Vérifier que la demande est correctement complétée
If IsNull(Me.txtDateDepart) + IsNull(Me.txtNbreJrs) < 0 Then
MsgBox "Veuillez compléter les deux champs.", vbCritical
Exit Sub
End If
'Purge éventuelle de la table tAffectations
'------------------------------------------
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete AffDate FROM tAffectations WHERE AffDate>=#" & Format(Me.txtDateDepart, "mm/dd/yyyy") & "#;"
DoCmd.SetWarnings True
'(Re)créer les enregistrements pour chacun des jours de la période
For I = 0 To Me.txtNbreJrs - 1
Call AffectationsDuJour(Me.txtDateDepart + I)
Next I
'Afficher le résultat
DoCmd.OpenForm "fAffectations"
Forms!fAffectations!txtDateDepart = Me.txtDateDepart
End SubLes commentaires inclus dans le code devraient suffire comme explications.
La routine AffectationsDuJour() est expliquée en détail dans le chapitre suivant.
VIII. La routine AffectationsDuJour ()▲
C'est l'algorithme qui va déterminer quels sont les deux candidats prioritaires pour chacune des pauses d'une journée.
VIII-A. La structure▲
VIII-B. Le code▲
Public Sub AffectationsDuJour(DateJ As Date)
Call RecalculDesRangs
Call CreerLaStructureDuJour(DateJ)
Call SelectionDeLaPaireDeCandidats(DateJ)
End SubVIII-B-1. Sub RecalculDesRangs()▲
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.
Public Sub RecalculDesRangs()
'-------------------------------
'Mise à jour du rang de priorité
'-------------------------------
Dim oRst As DAO.Recordset
Dim oFld As DAO.Field
'Compter les pauses où il est volontaire
Set oRst = CurrentDb.OpenRecordset("tVolontaires")
oRst.MoveFirst
Do Until oRst.EOF
oRst.Edit
oRst("Rang") = 0
oRst.Update
For Each oFld In oRst.Fields
If oFld.Name Like "???##-##" Then
oRst.Edit
oRst("Rang") = oRst("rang") - oRst(oFld.Name)
oRst.Update
End If
Next oFld
'Ajouter le compte de ses prestations anciennes
oRst.Edit
oRst("Rang") = oRst("Rang") + DCount("*", "tAffectations", "tVolontairesFK=" & oRst("tVolontairesPK") _
& " AND RangJour<=0 and MotifRejet =""""")
oRst.Update
oRst.MoveNext
Loop
'Forcer la priorité des Jokers
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE tVolontaires SET Rang = 1E+34 WHERE VolNom Like ""Joker*"";"
DoCmd.SetWarnings True
'Sortie
oRst.Close
Set oRst = Nothing
End Sub
Commentaires du code
33 : on affecte un nombre très grand au rang des jokers, pour s'assurer qu'ils seront seulement choisis en dernier ressort.
VIII-B-2. Sub CreerLaStructureDuJour()▲
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
Public Sub CreerLaStructureDuJour(DateJ As Date)
'--------------------------------
'Créer la structure d'une journée
'--------------------------------
Dim strCharnieres As String
Dim I As Integer
Dim strSql As String
Dim strNomColonne As String
strCharnieres = "06-09-12-15-18"
For I = 1 To 10 Step 3
'Nom de la colonne de tVolontaire
strNomColonne = Left(Format(DateJ, "dddd"), 3) & Mid(strCharnieres, I, 5)
'Ajout des candidats
DoCmd.SetWarnings False
strSql = "INSERT INTO tAffectations ( AffDate, AffPause, tVolontairesFK, RangJour ) " _
& "SELECT #" & Format(DateJ, "mm/dd/yyyy") & "# AS Expr1, """ & Mid(strCharnieres, I, 5) & """ AS Expr2, tVolontairesPK,Rang " _
& "FROM tVolontaires " _
& "WHERE [" & strNomColonne & "]=True;"
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
Next I
End Sub
Commentaires du code
15 : selon les valeurs successives de i, Mid(Charnieres, i, 5) vaudra successivement 06-09,09-12?
18-21 : la requête construite à la volée pour le 1er février 2016, pause 06-09, aura cet aspect :
VIII-B-3. Sub SelectionDeLaPaireDeCandidats()▲
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.
Public Sub SelectionDeLaPaireDeCandidats(DateJ As Date)
'---------------------------------------
'Sélection des candidats pause par pause
'---------------------------------------
Dim strCharnieres As String
Dim I As Integer
Dim strPause As String
Dim strPauseSuivante As String
Dim strSql As String
Dim oQry As DAO.QueryDef
strCharnieres = "06-09-12-15-18"
For I = 1 To 10 Step 3
strPause = Mid(strCharnieres, I, 5)
'Déterminer la pause suivante (servira à ReportPourPauseSuivanteer les 2 élus dans la pause suivante
's'ils sont aussi candidats
If I <= 7 Then
strPauseSuivante = Mid(strCharnieres, I + 3, 5)
Else
strPauseSuivante = ""
End If
'Écarter les candidats qui ont déjà rempli leur quota de prestations
strSql = "UPDATE tAffectations SET MotifRejet = RespectDesContraintesDuVolontaire([tVolontairesFK],#" _
& Format(DateJ, "mm/dd/yyyy") _
& "#,""" & strPause & """) " _
& "WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# AND AffPause=""" & strPause & """;"
DoCmd.SetWarnings False
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
'Actualiser rPauseEnCours (une requête enregistrée, => simplifier le code)
strSql = "SELECT tAffectationsPK, AffDate, AffPause, tVolontairesFK, RangJour, MotifRejet, VolNom " _
& "FROM tVolontaires INNER JOIN tAffectations ON tVolontaires.tVolontairesPK = tAffectations.tVolontairesFK " _
& "WHERE AffDate = #" & Format(DateJ, "mm/dd/yyyy") & "# And AffPause =""" & strPause & """ And MotifRejet="""" " _
& "ORDER BY RangJour, tVolontairesFK;"
Set oQry = CurrentDb.QueryDefs("rPauseEnCours")
oQry.SQL = strSql
'Retenir les 2 volontaires pour chaque pause
Call ElectionDeLaPaire(DateJ, strPause)
'ReportPourPauseSuivante de priorité
If strPauseSuivante <> "" Then Call ReportPourPauseSuivante(strPauseSuivante)
Next I
End Sub
Commentaires du code
26-30 : le code correspond à cette requête (1/2/2016, pause 06-09)
La fonction RespectDesContraintesDuVolontaire() est détaillée plus loin.
35-38 : on crée une requête qui extrait la tranche de la pause actuelle dans tPrestations :
Ceci pour faciliter l'écriture du code à certains endroits du programme.
VIII-B-4. Sub ElectionDeLaPaire()▲
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.
Public Sub ElectionDeLaPaire(DateJ As Date, Pause As String)
'--------------------------------------------------
'Retenir les 2 volontaires pour chaque pause
'en respectant les contraintes de dépendant/obligé
'et d'exclusion mutuelle
'--------------------------------------------------
Dim oRst As DAO.Recordset
Dim oRst2 As DAO.Recordset
Dim intNbreRetenus As Integer
Dim strSql As String
Dim oQry As DAO.QueryDef
Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")
oRst.MoveFirst
intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")
'Boucle pour retenir les 2 candidats prioritaires
Do While intNbreRetenus < 2
If oRst("RangJour") = -2 Then GoTo FinDesControles '(c'est le 2e membre d'une paire)
'Traitement des paires Dépendant/Obligé
Select Case StatutDuCandidat(oRst("tvolontairesFK"))
Case "Dépendant"
'l'éliminer si son obligé est absent, sinon retenir la paire
Set oRst2 = CurrentDb.OpenRecordset("SELECT VolObliFK FROM tCoVolObli WHERE tVolontairesFK=" & oRst("tVolontairesFK") & ";")
oRst2.MoveFirst
Do Until oRst2.EOF
If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("VolObliFK")) > 0 Then 'l'obligé est présent
oRst.Edit
oRst("RangJour") = -2
oRst.Update
'Mettre le rang de l'obligé à -2
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2 " _
& "WHERE tVolontairesFK=" & oRst2("VolObliFK") & ";"
DoCmd.SetWarnings True
oRst2.Close
GoTo FinDesControles
End If
oRst2.MoveNext
Loop
oRst2.Close
'Si on arrive ici, pas d'obligé présent pour ce dépendant
oRst.Edit
oRst("MotifRejet") = "ObligéAbsent"
oRst.Update
GoTo FinDesControles
Case "Obligé"
'Si son dépendant est aussi candidat, on les prend tous les deux
Set oRst2 = CurrentDb.OpenRecordset("SELECT tVolontairesFK FROM tCoVolObli WHERE VolObliFK=" & oRst("tVolontairesFK") & ";")
oRst2.MoveFirst
Do Until oRst2.EOF
If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("tVolontairesFK")) > 0 Then 'le dépendant est présent
oRst.Edit
oRst("RangJour") = -2
oRst.Update
'Mettre le rang du dépendant à -2
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2 " _
& "WHERE tVolontairesFK=" & oRst2("tVolontairesFK") & ";"
DoCmd.SetWarnings True
oRst2.Close
GoTo FinDesControles
End If
oRst2.MoveNext
Loop
oRst2.Close
End Select
'N.B. On arrive ici pour tous les ordinaires et obligés seuls
'Ce candidat est élu
oRst.Edit
oRst("RangJour") = 0
oRst.Update
'Y a-t-il une incompatibilité concernant ce candidat ?
'----------------------------------------------------
'Si non, on passe au suivant
If ControleDesIncompatibilites(oRst("tVolontairesFK")) = "" Then GoTo FinDesControles
'Si oui, éliminer les autres volontaires (éventuels) du groupe ayant une moindre priorité
strSql = "UPDATE tAffectations SET MotifRejet = ""Incompatible"" , RangJour =1E+35 " _
& " WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# " _
& "AND AffPause=""" & Pause & """ " _
& "AND RangJour>0 " _
& "AND tVolontairesFK In(" & ControleDesIncompatibilites(oRst("tVolontairesFK")) & ");"
DoCmd.SetWarnings False
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
FinDesControles:
intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")
oRst.MoveNext
Loop
'Retenir les 2 candidats pour cette pause
'----------------------------------------
Set oRst = CurrentDb.OpenRecordset("SELECT * FROM rPauseEnCours ORDER BY RangJour;")
oRst.MoveFirst
oRst.Move 2
Do Until oRst.EOF
oRst.Edit
If oRst("MotifRejet") = "" Then oRst("MotifRejet") = "Non prioritaire"
oRst.Update
oRst.MoveNext
Loop
'Sortie
Set oQry = Nothing
oRst.Close
Set oRst = Nothing
Set oRst2 = Nothing
End Sub
Commentaires du code
15 : rappelons que la requête ramène les candidats à la pause, classés dans l'ordre de leur priorité, pour autant qu'ils n'aient pas été éliminés à l'étape précédente.
20 : on sortira de la boucle, lorsqu'au moins deux candidats auront été élus.
23 : le statut d'un candidat va influencer le choix.
24-50 : le candidat est dépendant.
Il ne peut être retenu que si son obligé est toujours en lice.
|
|
Si cette partie du code est sollicitée lors du traitement, c'est que l'obligé a une priorité inférieure à celle de ce dépendant. |
26-40 : si on constate la présence de son obligé parmi les candidats encore en lice pour cette pause, on leur attribue le rang -2. On saute alors à l'instruction 116 qui nous fera sortir de la boucle : le nombre d'élus est alors au moins égal à 2 !
45-50 : si on arrive ici, c'est que le dépendant est orphelin et on l'élimine avant de passer au candidat suivant.
51-72 : le candidat est obligé.
Le raisonnement est semblable au cas précédent sauf que si le dépendant n'est pas en lice, l'obligé est traité comme un candidat ordinaire et on continue le traitement à l'instruction 73.
73-77 : si un candidat ordinaire ne fait pas partie de l'ensemble des exclus mutuels, il reçoit un rang prioritaire = 0 et on passe au candidat suivant.
|
|
L'élection d'un candidat ordinaire qui fait partie d'un ensemble d'exclus mutuels entraîne l'élimination des autres membres du groupe qui ont une priorité inférieure. |
La fonction ControleDesIncompatibilites()
Public Function ControleDesIncompatibilites(idVol As Long) As String
Dim oRst As DAO.Recordset
'Qui exclut-il ?
Set oRst = CurrentDb.OpenRecordset("SELECT VolExclusFK FROM tCoVolExclus " _
& "WHERE tVolontairesFK=" & idVol & ";")
Do Until oRst.EOF
ControleDesIncompatibilites = ControleDesIncompatibilites & oRst("VolExclusFK") & ","
oRst.MoveNext
Loop
'Par qui est-il exclu ?
Set oRst = CurrentDb.OpenRecordset("SELECT tVolontairesFK FROM tCoVolExclus " _
& "WHERE VolExclusFK=" & idVol & ";")
Do Until oRst.EOF
ControleDesIncompatibilites = ControleDesIncompatibilites & oRst("tVolontairesFK") & ","
oRst.MoveNext
Loop
oRst.Close
Set oRst = Nothing
End FunctionPar exemple pour ARNOTHY :
D'une part ARNOTHY (3) ne veut pas venir si ABBOTT Jeff (1) ou FRENCH Nicci (18) vient.
Et d'autre part ni HEMINGWAY Ernest (5), ni MAIGRET Jules (7) ne veulent ARNOTHY comme coéquipière.
Lorsqu'il n'y a pas d'incompatibilité, la fonction envoie un résultat vide (« "" »).
Par exemple pour ASSOULINE :
82 : s'il n'y a pas d'exclusion mutuelle, on passe au suivant.
84-91 : s'il y a exclusion mutuelle, les autres membres du groupe doivent être écartés : on met leur rang prioritaire à 1E+35 (donc ils viendront après les jokers qui ont 1E+34).
Voici la requête qui est créée à la volée, lors du traitement de ARNOTHY le 11/1/16 pour 06-09 :
98-108 : quand deux candidats ont été élus, on sort de la boucle, on relit rPausesEnCours dans l'ordre des priorités croissantes, on saute les deux premiers enregistrements (les élus) et on écrit « Non prioritaire » dans la colonne MotifDuRejet si elle est encore vierge.
VIII-B-5. Sub ReportPourPauseSuivante()▲
|
|
Autre a priori de l'algorithme : le candidat élu pour une pause est systématiquement réélu pour la pause suivante (pour autant bien sûr qu'il soit candidat). |
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.
Public Sub ReportPourPauseSuivante(PauseSuivante As String)
'---------------------------------------------------------------------------------------------------------
'Sauf si joker, les 2 élus d'une pause deviennent prioritaires pour la pause suivante s'ils sont candidats
'---------------------------------------------------------------------------------------------------------
Dim oRst As DAO.Recordset
Dim strSql As String
'ReportPourPauseSuivanteer (éventuellement) les 2 élus dans la pause suivante
Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")
oRst.MoveFirst
Do While Not oRst.EOF
If oRst("VolNom") <> "Joker" Then
strSql = "UPDATE tAffectations SET RangJour = -1 " _
& "WHERE AffDate=#" & Format(oRst("affDate"), "mm/dd/yyyy") & "# " _
& "AND AffPause=""" & PauseSuivante & """ " _
& "AND tVolontairesFK=" & oRst("tVolontairesFK") _
& "AND MotifRejet="""";"
DoCmd.SetWarnings False
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
End If
If oRst.AbsolutePosition = 1 Then Exit Do
oRst.MoveNext
Loop
'Sortie
oRst.Close
Set oRst = Nothing
End Sub
15-19 : voici par exemple la requête qui serait générée à l'issue de la pause 06-09 du 1/1/2017 pour CHRISTIE (15) qui a été élue.
|
|
Remarquez la mise à -1 de RangJour. |
VIII-B-6. La fonction RespectDesContraintesDuVolontaire()▲
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.
Public Function RespectDesContraintesDuVolontaire(idVol As Long, DateJ As Date, Pause As String) As String
On Error GoTo GestionErreurs
Dim vntRes As Variant
Dim intNbrePauses As Integer
Dim dtnPrestaPrec As Date
Dim intMaxPresta As Integer
Dim oRst As DAO.Recordset
'Contrainte MaxPauses
'--------------------
vntRes = DLookup("MaxPauses", "tVolontaires", "tVolontairesPK=" & idVol)
If Not IsNull(vntRes) Then
'Combien de pauses aujourd'hui ?
intNbrePauses = DCount("tAffectationsPK", "tAffectations", _
"AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# And tVolontairesFK=" & idVol _
& " AND AffPause <= """ & Pause & """ AND MotifRejet=""""")
If intNbrePauses >= vntRes Then
RespectDesContraintesDuVolontaire = ">MaxPauses"
Exit Function
End If
End If
'Contrainte Espace journées
'--------------------------
vntRes = DLookup("NbreMinInter", "tVolontaires", "tVolontairesPK=" & idVol)
If Not IsNull(vntRes) Then
'Recherche date précédentes prestations
dtnPrestaPrec = Nz(DMax("AffDate", "tAffectations", _
"AffDate<#" & Format(DateJ, "mm/dd/yyyy") _
& "# And tVolontairesFK=" & idVol & " AND MotifRejet="""""), #1/1/1900#)
'Vérif espace
If DateJ - dtnPrestaPrec <= vntRes Then
RespectDesContraintesDuVolontaire = "<EspaceJrs"
Exit Function
End If
End If
'Maximum prestations/semaine
'---------------------------
intMaxPresta = Nz(DLookup("NbreMaxJrsSem", "tVolontaires", "tVolontairesPK=" & idVol), 1000)
If intMaxPresta <> 1000 Then
'Sommes-nous <>lundi ?
If Format(DateJ, "dddd") <> "lundi" Then
'Rechercher date précédent lundi
vntRes = DateJ
Do Until Format(vntRes, "dddd") = "lundi"
vntRes = vntRes - 1
Loop
'Compter les prestations depuis lundi
Set oRst = CurrentDb.OpenRecordset("SELECT DISTINCT AffDate FROM tAffectations " _
& "WHERE AffDate>=#" & Format(vntRes, "mm/dd/yyyy") _
& "# AND tVolontairesFK=" & idVol _
& " AND MotifRejet ="""";")
'Vérifier le non-dépassement
oRst.MoveLast
If oRst.RecordCount >= intMaxPresta Then
RespectDesContraintesDuVolontaire = ">PrestaJrs"
Exit Function
End If
End If
End If
GestionErreurs:
Select Case Err.Number
Case 0 ' pas d'erreur
Exit Function
Case 3021 'pas d'enregistrement de prestations passées
Exit Function
Case Else
MsgBox "Erreur dans RespectDesContraintesDuVolontaire : " & Err.Number & " " & Err.Description & " !"
End Select
End Function
Les commentaires inclus dans le code devraient suffire à la compréhension.
30 et 41 : remarquez l'utilisation de la fonction Nz() qui substituera une valeur extrême (1/1/1900 pour une date de précédente prestation ; 1000 pour un nombre maximum de pauses par jour) quand il y a risque d'un retour Null.