Sujet Précédent Sujet Suivant

Incrémentation automatique dans calendrier access 2000

cacahuete34 Messages postés 2 Date d'inscription jeudi 2 décembre 2010 Statut Membre Dernière intervention 6 décembre 2010 - 3 déc. 2010 à 10:19
cacahuete34 Messages postés 2 Date d'inscription jeudi 2 décembre 2010 Statut Membre Dernière intervention 6 décembre 2010 - 6 déc. 2010 à 11:51
Bonjour à tous,

Je viens de télécharger le fichier "Calendrier par mois VBA access" créé et publié par PILLSMEN car je pense qu'il correspond exactement à ce que je recherchais. (http://www.vbfrance.com/codes/CALENDRIER-MOIS-VBA-ACCESS_42460.aspx)

En effet, je monte une base de données où je référence des produits qui doivent être vérifiés à des dates précises.

Je souhaiterai pouvoir renseigner dans le formulaire "fiche produit" la date butoir en la sélectionnant depuis le formulaire "calendrier" et que l'intitulé du produit s'incrémente dans ce calendrier.
Ainsi, en regardant le calendrier, je pourrai avoir les dates de vérification de tous les produits.

Le problème est que je débute sur access, que la programmation VBA ressemble au chinois pour moi et que j'ai un délai très court pour finir ce projet...

Merci de votre aide.

A bientôt

1 réponse

Réponse 1 / 1
cacahuete34 Messages postés 2 Date d'inscription jeudi 2 décembre 2010 Statut Membre Dernière intervention 6 décembre 2010
6 déc. 2010 à 11:51
Bonjour,

Je vous transmets le code afin que vous puissiez regardez de plus près.

Merci de votre aide!!!

Option Compare Database
Option Explicit
'Sauvegarde de l'élément en cour de selection
Public elem_selected As Object
'Sauvegarde de la couleur de fond de l'élément avant sa sélection
Public text_color_old As Long
'Couleur de sélection par défaut
Const SelectColor = 12632256
'Couleur des jours non ouvrés (WE + fériés) par défaut
Const NotWorkedColor = 15987699
'Couleur "normale"
Const NormalColor = 16777215
Private Sub Form_Load()
Dim i As Integer
Dim Bouton_Jour As Object

'On récupère l'argument de l'ouverture du calendrier s'il y en a un et on sélectionne les bonnes valeurs de jour, mois, année.
'S'il n'y a pas d'argument, on initialise le calendrier à la date du jour
Dim Jour_init As Date
If Not IsNull(Me.OpenArgs) Then Jour_init Format$(Me.OpenArgs, "MM\/DD\/YYYY") Else Jour_init Date

'Initialisation des listes déroulantes du mois et de l'année
Me.Liste_Mois.RowSource = "1;Janvier;2;Février;3;Mars;4;Avril;5;Mai;6;Juin;7;Juillet;8;Août;9;Septembre;10;Octobre;11;Novembre;12;Décembre"
Me.Liste_Annee.RowSource = ""
For i = 1900 To CInt(Year(Date)) + 100
Me.Liste_Annee.AddItem (CStr(i))
Next
'Selection du mois et de l'année en cours
Liste_Mois = Liste_Mois.ItemData(CInt(Month(Jour_init)) - 1)
Liste_Annee = Liste_Annee.ItemData(CInt(Year(Jour_init)) - 1900)

'On met le titre du mois et de l'année à jour
Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee

'On sélectionne la case relative à la date du jour
i = (Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1)
If i 0 Then i 7
If i 1 Then i 8
i = i + CInt(Day(Jour_init)) - 1

'On initialise la variable d'élément selectionné au bouton du jour
Set Bouton_Jour = NumObject(i)
With Bouton_Jour
Set elem_selected = Bouton_Jour
End With
'On initialise le calcul des jours (jours associés à la date)
CalculJours

End Sub
Private Sub Liste_Annee_AfterUpdate()
'On réactualise le titre (mois + année)
Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
'On réinitialise le calcul des jours (jours associés à la date)
CalculJours
End Sub
Private Sub Liste_Mois_Change()
'On réactualise le titre (mois + année)
Me.MonthYear.Caption = Me.Liste_Mois.Column(1) & " " & Me.Liste_Annee
'On réinitialise le calcul des jours (jours associés à la date)
CalculJours
End Sub
'Procédure évènementielle de chaque case du calendrier
'Lorsque l'on clique, on rend la couleur et l'aspect d'origine à la case qui était selectionnée avant
'et on donne l'aspect "appuyé" et la couleur de fond à la case "en cour"
Private Sub J1_Click()
If Me.J1.SpecialEffect = 0 Then
SelectDay (1)
End If
End Sub
Private Sub J2_Click()
If Me.J2.SpecialEffect = 0 Then
SelectDay (2)
End If
End Sub
Private Sub J3_Click()
If Me.J3.SpecialEffect = 0 Then
SelectDay (3)
End If
End Sub
Private Sub J4_Click()
If Me.J4.SpecialEffect = 0 Then
SelectDay (4)
End If
End Sub
Private Sub J5_Click()
If Me.J5.SpecialEffect = 0 Then
SelectDay (5)
End If
End Sub
Private Sub J6_Click()
If Me.J6.SpecialEffect = 0 Then
SelectDay (6)
End If
End Sub
Private Sub J7_Click()
If Me.J7.SpecialEffect = 0 Then
SelectDay (7)
End If
End Sub
Private Sub J8_Click()
If Me.J8.SpecialEffect = 0 Then
SelectDay (8)
End If
End Sub
Private Sub J9_Click()
If Me.J9.SpecialEffect = 0 Then
SelectDay (9)
End If
End Sub
Private Sub J10_Click()
If Me.J10.SpecialEffect = 0 Then
SelectDay (10)
End If
End Sub
Private Sub J11_Click()
If Me.J11.SpecialEffect = 0 Then
SelectDay (11)
End If
End Sub
Private Sub J12_Click()
If Me.J12.SpecialEffect = 0 Then
SelectDay (12)
End If
End Sub
Private Sub J13_Click()
If Me.J13.SpecialEffect = 0 Then
SelectDay (13)
End If
End Sub
Private Sub J14_Click()
If Me.J14.SpecialEffect = 0 Then
SelectDay (14)
End If
End Sub
Private Sub J15_Click()
If Me.J15.SpecialEffect = 0 Then
SelectDay (15)
End If
End Sub
Private Sub J16_Click()
If Me.J16.SpecialEffect = 0 Then
SelectDay (16)
End If
End Sub
Private Sub J17_Click()
If Me.J17.SpecialEffect = 0 Then
SelectDay (17)
End If
End Sub
Private Sub J18_Click()
If Me.J18.SpecialEffect = 0 Then
SelectDay (18)
End If
End Sub
Private Sub J19_Click()
If Me.J19.SpecialEffect = 0 Then
SelectDay (19)
End If
End Sub
Private Sub J20_Click()
If Me.J20.SpecialEffect = 0 Then
SelectDay (20)
End If
End Sub
Private Sub J21_Click()
If Me.J21.SpecialEffect = 0 Then
SelectDay (21)
End If
End Sub
Private Sub J22_Click()
If Me.J22.SpecialEffect = 0 Then
SelectDay (22)
End If
End Sub
Private Sub J23_Click()
If Me.J23.SpecialEffect = 0 Then
SelectDay (23)
End If
End Sub
Private Sub J24_Click()
If Me.J24.SpecialEffect = 0 Then
SelectDay (24)
End If
End Sub
Private Sub J25_Click()
If Me.J25.SpecialEffect = 0 Then
SelectDay (25)
End If
End Sub
Private Sub J26_Click()
If Me.J26.SpecialEffect = 0 Then
SelectDay (26)
End If
End Sub
Private Sub J27_Click()
If Me.J27.SpecialEffect = 0 Then
SelectDay (27)
End If
End Sub
Private Sub J28_Click()
If Me.J28.SpecialEffect = 0 Then
SelectDay (28)
End If
End Sub
Private Sub J29_Click()
If Me.J29.SpecialEffect = 0 Then
SelectDay (29)
End If
End Sub
Private Sub J30_Click()
If Me.J30.SpecialEffect = 0 Then
SelectDay (30)
End If
End Sub
Private Sub J31_Click()
If Me.J31.SpecialEffect = 0 Then
SelectDay (31)
End If
End Sub
Private Sub J32_Click()
If Me.J32.SpecialEffect = 0 Then
SelectDay (32)
End If
End Sub
Private Sub J33_Click()
If Me.J33.SpecialEffect = 0 Then
SelectDay (33)
End If
End Sub
Private Sub J34_Click()
If Me.J34.SpecialEffect = 0 Then
SelectDay (34)
End If
End Sub
Private Sub J35_Click()
If Me.J35.SpecialEffect = 0 Then
SelectDay (35)
End If
End Sub
Private Sub J36_Click()
If Me.J36.SpecialEffect = 0 Then
SelectDay (36)
End If
End Sub
Private Sub J37_Click()
If Me.J37.SpecialEffect = 0 Then
SelectDay (37)
End If
End Sub
Private Sub J38_Click()
If Me.J38.SpecialEffect = 0 Then
SelectDay (38)
End If
End Sub
Private Sub J39_Click()
If Me.J39.SpecialEffect = 0 Then
SelectDay (39)
End If
End Sub
Private Sub J40_Click()
If Me.J40.SpecialEffect = 0 Then
SelectDay (40)
End If
End Sub
Private Sub J41_Click()
If Me.J41.SpecialEffect = 0 Then
SelectDay (41)
End If
End Sub
Private Sub J42_Click()
If Me.J42.SpecialEffect = 0 Then
SelectDay (42)
End If
End Sub
'Cette fonction permet le calcul des dates par jour, une fois le premier jour du mois ainsi que "sa case" ait été détectés,
'on remplit les premières cases avec les numéros des jours du mois précédent, puis on continue avec les cases du mois en cours
'pour finir avec les jours du mois suivant
Private Function CalculJours()
Dim i As Integer
Dim DateDebutMois As Date
Dim k As Integer
Dim Bouton_Jour As Object

'On calcule k, le nb de jour du mois précédent à afficher sur le calendrier
If Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 0 Then
k = 7
ElseIf Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 1 Then
k = 8
Else
k = Weekday(DateSerial(Liste_Annee, Liste_Mois, 1) - 1)
End If

'On calcule le numéro du premier jour du mois précédent selon la date selectionnée grâce aux listes et le k
DateDebutMois = DateAdd("d", -k + 1, DateSerial(Liste_Annee, Liste_Mois, 1))

For i = 0 To 41
'Pour chaque jours de la semaine
Set Bouton_Jour = NumObject(i + 1)
With Bouton_Jour
'On affecte à la case en cours le numéro de son jour
.Caption = Day(DateAdd("d", i, DateDebutMois))
'Et on colore la police des cases du mois en cours différemment des cases du mois précédent et suivant
If CInt(Month(DateAdd("d", i, DateDebutMois))) <> Liste_Mois Then
.ForeColor = 8421504
Else
.ForeColor = 10485760
End If
'On colore l'arrière plan des cases qui sont des samedi, dimanche, ou des jours fériés
If ((i + 2) Mod 7 0) Or ((i + 1) Mod 7 0) Or IsFerie(DateAdd("d", i, DateDebutMois)) Then
.BackColor = NotWorkedColor
Else
.BackColor = NormalColor
End If
End With
Next

'On donne au bouton selectionné les attributs de la selection (couleur, aspect, etc...)
With elem_selected
.SpecialEffect = 2
'Dans le cas d'une case "WE" ou fériée, on sauvegarde la bonne couleur
If ((((CInt(Right(.Name, Len(.Name) - 1)) + 1) Mod 7) 0 Or (CInt(Right(.Name, Len(.Name) - 1)) Mod 7) 0)) Then
text_color_old = NotWorkedColor
Else
text_color_old = .BackColor
End If
.BackColor = SelectColor
End With
End Function
Public Function SelectDay(num_case As Integer)
Dim Case_jour As Object
Set Case_jour = NumObject(num_case)
With Case_jour
DeSelectPreviousDay
.SpecialEffect = 2
'Sauvegarde de la couleur de la case
text_color_old = .BackColor
'Affectation de la couleur de sélection
.BackColor = SelectColor
'Mise à jour de la variable case en cour de sélection
Set elem_selected = Case_jour
End With
MsgBox ReturnDate
End Function
Private Function DeSelectPreviousDay()
With elem_selected
.SpecialEffect = 0
.BackColor = text_color_old
End With
End Function
'Cette fonction permet de contourner l'interdiction d'avoir une variable tableau public
'Elle retourne un objet qui désigne une case du calendrier en fonction de sa position (facilement calculable)
Private Function NumObject(j As Integer) As Object
Dim Bouton_Jour(42) As Object

'On initialise le tableau d'objets
Set Bouton_Jour(1) = Me.J1
Set Bouton_Jour(2) = Me.J2
Set Bouton_Jour(3) = Me.J3
Set Bouton_Jour(4) = Me.J4
Set Bouton_Jour(5) = Me.J5
Set Bouton_Jour(6) = Me.J6
Set Bouton_Jour(7) = Me.J7
Set Bouton_Jour(8) = Me.J8
Set Bouton_Jour(9) = Me.J9
Set Bouton_Jour(10) = Me.J10
Set Bouton_Jour(11) = Me.J11
Set Bouton_Jour(12) = Me.J12
Set Bouton_Jour(13) = Me.J13
Set Bouton_Jour(14) = Me.J14
Set Bouton_Jour(15) = Me.J15
Set Bouton_Jour(16) = Me.J16
Set Bouton_Jour(17) = Me.J17
Set Bouton_Jour(18) = Me.J18
Set Bouton_Jour(19) = Me.J19
Set Bouton_Jour(20) = Me.J20
Set Bouton_Jour(21) = Me.J21
Set Bouton_Jour(22) = Me.J22
Set Bouton_Jour(23) = Me.J23
Set Bouton_Jour(24) = Me.J24
Set Bouton_Jour(25) = Me.J25
Set Bouton_Jour(26) = Me.J26
Set Bouton_Jour(27) = Me.J27
Set Bouton_Jour(28) = Me.J28
Set Bouton_Jour(29) = Me.J29
Set Bouton_Jour(30) = Me.J30
Set Bouton_Jour(31) = Me.J31
Set Bouton_Jour(32) = Me.J32
Set Bouton_Jour(33) = Me.J33
Set Bouton_Jour(34) = Me.J34
Set Bouton_Jour(35) = Me.J35
Set Bouton_Jour(36) = Me.J36
Set Bouton_Jour(37) = Me.J37
Set Bouton_Jour(38) = Me.J38
Set Bouton_Jour(39) = Me.J39
Set Bouton_Jour(40) = Me.J40
Set Bouton_Jour(41) = Me.J41
Set Bouton_Jour(42) = Me.J42

'On retourne l'objet correspondant au paramètre
Set NumObject = Bouton_Jour(j)
End Function
'Fonction qui retourne la date de la case sélectionnée sous le format jj/mm/aaaa
Private Function ReturnDate() As Date
Dim DateDebutMois As Date
Dim i As Integer
'On calcule i, le nb de jour du mois précédent à afficher sur le calendrier
If Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 0 Then
i = 7
ElseIf Weekday(DateSerial(Liste_Annee, Liste_Mois, 1)) - 1 = 1 Then
i = 8
Else
i = Weekday(DateSerial(Liste_Annee, Liste_Mois, 1) - 1)
End If

'On calcule le numéro du premier jour du mois précédent selon la date selectionnée grâce aux listes et le k
DateDebutMois = DateAdd("d", -i + 1, DateSerial(Liste_Annee, Liste_Mois, 1))
'On récupère le numéro de la case
With elem_selected
i = CInt(Right(.Name, Len(.Name) - 1))
End With
'On calcule la date de la case selectionnée et on la renvoie
ReturnDate = DateAdd("d", i - 1, DateDebutMois)
End Function
'Fonction trouvée sur www.codes-sources.fr/www.vbfrance.com
'http://www.vbfrance.com/code.aspx?ID=1251
Private Function IsFerie(Date_testee As Date) As Boolean
Dim JJ, AA, MM As Integer
Dim NbOr, Epacte As Integer
Dim PLune, Paques, Ascension, Pentecote As Date
JJ = Day(Date_testee)
MM = Month(Date_testee)
AA = Year(Date_testee)
If JJ 1 And MM 1 Then IsFerie = True: Exit Function '1 Janvier
If JJ 1 And MM 5 Then IsFerie = True: Exit Function '1 Mai
If JJ 8 And MM 5 Then IsFerie = True: Exit Function '8 Mai
If JJ 14 And MM 7 Then IsFerie = True: Exit Function '14 Juillet
If JJ 15 And MM 8 Then IsFerie = True: Exit Function '15 Août
If JJ 1 And MM 11 Then IsFerie = True: Exit Function '1 Novembre
If JJ 11 And MM 11 Then IsFerie = True: Exit Function '11 Novembre
If JJ 25 And MM 12 Then IsFerie = True: Exit Function '25 Décembre
NbOr = (AA Mod 19) + 1
Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
PLune = DateSerial(AA, 4, 19) - ((Epacte + 6) Mod 30)
If Epacte 24 Then PLune PLune - 1
If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = PLune - 1
Paques = PLune - Weekday(PLune) + vbMonday + 7 'Paques
If JJ Day(Paques) And MM Month(Paques) Then IsFerie = True: Exit Function
Ascension = Paques + 38 'Ascension
If JJ Day(Ascension) And MM Month(Ascension) Then IsFerie = True: Exit Function
Pentecote = Ascension + 11 'Pentecote
If JJ Day(Pentecote) And MM Month(Pentecote) Then IsFerie = True: Exit Function
IsFerie = False
End Function
0

Discussions similaires

Incrémentation
Moundir76 -
Moundir76 -

24 réponses
Modèle pour créer un formulaire Calendrier dans ACCESS
VBMegderic -
samibrik -

2 réponses
macro pour écriture automatique
thomthom27 -
simH -

3 réponses
gestion de Parking PHP
intelloyassine -
syndrael -

5 réponses
Défilement automatique d'une page
cs_scls19fr -
DevDeb -

19 réponses
Rejoignez-nous