Calendrier sous acces 2000

Télécharger le projet
Commenter

Description

Vous en avez marre de taper des dates ?
Avec un formulaire et un module, vous pourrez ajouter un calendrier à vos applications.

Il gère les jours fériés, un affichage different pour les jours ouvrés.
Pour les jours ouvrés j'ai choisi de passer par un fichier ".ini" car je me sers du calendrier comme complément installé. ce qui permet à l'utilsateur final de modifier les jours ouvrés sans avoir acces aux sources.

Inserez :

Zone_a_dater = calendrier(zone_a_dater)

Le parametre permet d'afficher la date qu'il y a dans la zone avant d'afficher le calendrier, si vous ne passez rien, le calendrier par de la date systeme de votre ordi.

Manipulation:
- echap pour annuler
- double clic ou touche entrée pour valider
- déplacement avec les fleches directionnelles possible
- pageup/down fait descendre/monter dans les mois

bon ok, c pas terrible, mais depuis que je pompe des trucs ici, je me devais de mettre qqchose. Destiné aux débutans, ou aux fleimards comme moi.

Source / Exemple : 


'
' 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
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.