CALENDRIER SOUS ACCES 2000

'
' CALENDRIER
' JerryMcFly -  08/04/2000                                                       
'

Option Compare Database


'*
'* Définition des parametres et variables
'*

'### Parametres : Jours Ouvrés
Public JO1 As Boolean
Public JO2 As Boolean
Public JO3 As Boolean
Public JO4 As Boolean
Public JO5 As Boolean
Public JO6 As Boolean
Public JO7 As Boolean

'### Constantes : Couleurs
Const Couleur_Jour_NO = 13209
Const Couleur_Jour_O = 0

'### Varaibles
Public Vdate As String
Public Vjour As Integer
Public Vsemaine As Integer
Public Vmois As Integer
Public Vannée As Long
Public Vprem_jour As Integer
Public Vnb_jours As Integer

'### Initialisation des parametres
Private Function init_param()
    JO1 = GetIni("JOURS OUVRES", "Lundi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO2 = GetIni("JOURS OUVRES", "Mardi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO3 = GetIni("JOURS OUVRES", "Mercredi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO4 = GetIni("JOURS OUVRES", "Jeudi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO5 = GetIni("JOURS OUVRES", "Vendredi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO6 = GetIni("JOURS OUVRES", "Samedi", CurrentProject.Path & "\parametres\Calendrier.ini")
    JO7 = GetIni("JOURS OUVRES", "Dimanche", CurrentProject.Path & "\parametres\Calendrier.ini")
End Function

'### 1ere Initialisation du calendrier a l'ouverture
Private Sub Form_Load()
init_param
calc_var
End Sub

'*
'* Capture des evenements Clavier
'*
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        'annulation - validation
        Case vbKeyEscape: Vdate = "": Me.Visible = False
        Case vbKeyReturn: Me.Visible = False
        'deplacement dans les jours
        Case vbKeyRight: Vdate = DateAdd("d", 1, Vdate): calc_var
        Case vbKeyLeft: Vdate = DateAdd("d", -1, Vdate): calc_var
        'deplacement dans les semaines
        Case vbKeyDown: Vdate = DateAdd("d", 7, Vdate): calc_var
        Case vbKeyUp: Vdate = DateAdd("d", -7, Vdate): calc_var
        'deplacement dans les mois
        Case vbKeyPageUp: Vdate = DateAdd("m", -1, Vdate): calc_var
        Case vbKeyPageDown: Vdate = DateAdd("m", 1, Vdate): calc_var
    End Select
    KeyCode = 0
End Sub



'*
'*  FONCTION PRINCIPALE : calcul des variables et affichage du calendrier
'*
Private Function calc_var()
    Dim PT As Integer: Dim PTCase As String
    
    If Vdate = "" Or IsNull(Vdate) Then Vdate = Date
    Vjour = CInt(Day(Vdate))
    Vmois = CInt(Month(Vdate))
    Vannée = CLng(Year(Vdate))
    Vprem_jour = CInt(Weekday("01/" & Vmois & "/" & Vannée, vbMonday))
    Vnb_jours = CInt((DateAdd("m", 1, "01/" & Vmois & "/" & Vannée) _
                - (CDate("01/" & Vmois & "/" & Vannée))))
    
    'Masquage de toutes les cases
    For PT = 1 To 42
        PTCase = "J" & Format(PT, "00")
        Me(PTCase).BorderStyle = 0
        Me(PTCase).Visible = False
    Next
    
    'Affichage des jours
    For PT = 1 To Vnb_jours
        PTCase = "J" & Format(PT + Vprem_jour - 1, "00")
        With Me(PTCase)
            .ForeColor = Couleur_jour(PT & "/" & Vmois & "/" & Vannée)
            If Ferié(PT & "/" & Vmois & "/" & Vannée) Then .ForeColor = Couleur_Jour_NO
            .Caption = PT
            .Visible = True
            If PT = Vjour Then .BorderStyle = 1
        End With
    Next
    ListMois = Vmois
    SelAnnée = Vannée
End Function

'*
'* SS Fonction, renvoie la couleur du jour en Fonction de Jour ouvré OUI/NON
'*
Private Function Couleur_jour(Journée) As Long
    Couleur_jour = Couleur_Jour_NO
    Select Case Weekday(Journée, vbMonday)
        Case 1: If JO1 Then Couleur_jour = Couleur_Jour_O
        Case 2: If JO2 Then Couleur_jour = Couleur_Jour_O
        Case 3: If JO3 Then Couleur_jour = Couleur_Jour_O
        Case 4: If JO4 Then Couleur_jour = Couleur_Jour_O
        Case 5: If JO5 Then Couleur_jour = Couleur_Jour_O
        Case 6: If JO6 Then Couleur_jour = Couleur_Jour_O
        Case 7: If JO7 Then Couleur_jour = Couleur_Jour_O
    End Select
End Function

'*
'* SS Fonction, encadre le jour demandé                                                         
'*
Private Function Eff_Bords(JS As Integer)
    'Masquage de tous les contours
    For i = 1 To 42
        Icase = "J" & Format(i, "00")
        Me(Icase).BorderStyle = 0
        If i = JS Then Me(Icase).BorderStyle = 1
    Next
    Icase = "J" & Format(JS, "00")
    Vdate = JS - Vprem_jour + 1 & "/" & Vmois & "/" & Vannée
    Do While Not Me(Icase).Visible
        JS = JS - 1
        Vdate = JS - Vprem_jour + 1 & "/" & Vmois & "/" & Vannée
    Loop
End Function

'*
'* Déplacements dans les Mois et années par les contrôles du formulaire 
'*
Private Sub ListMois_AfterUpdate()
Vdate = DateAdd("m", ListMois - Vmois, Vdate): calc_var
End Sub
Private Sub SpinMois_SpinDown()
Vdate = DateAdd("yyyy", -1, Vdate): calc_var
End Sub
Private Sub SpinMois_SpinUp()
Vdate = DateAdd("yyyy", 1, Vdate): calc_var
End Sub