Calendrier portable

Bonjour,

De rien. Merci à toi pour avoir lancé ce sujet.

A bientôt

Bonjour,

très beau boulot, j'avais trouvé un site mais les liens de téléchargement ne fonctionnaient plus

puis miracle je retrouve le fichier sur ce site, mais voila

une erreur à l'ouverture du fichier calendrier_portable-3.1.xls apparemment à ma version 64 bit

Erreur de compilation

le code contenu dans ce projet doit être mis à jour pour pouvoir être utilisé sur les systèmes 64 bits vérifiez et mettez à jour les instructions declare, puis marquez-les avec l'attribut PrtSafe

lignes en erreur coté VBA

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

voila je continue a chercher une solution

encore merci pour ce boulot très intéressant

Bonjour,

Une solution pour les systèmes 32 et 64 bytes :

Dans module1

remplacer ce code

    Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Public Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long

par celui-ci :

#If Win64 Then
    Public Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Public Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Public Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
#Else
    Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Public Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
#End If

Bonjour,

Je bosse actuellement sur la version 4 de ce calendrier.

Cette version se veut :

  • plus simple à mettre en œuvre,
  • plus intuitive,
  • plus transportable.

Simplifications :

Elle se composera d'un seul Module de Classe. Fini le module Userform + le module de classe.

1 seul module = facilité de "transportabilité" d'un classeur à l'autre.

Le code d'appel est également simplifié par la création d'une méthode Value. Ainsi, il suffira de déclarer une variable et d'en appeler la Value, du genre :

Dim myForm As New Calendrier
Debug.Print myForm.Value

Intuitivité :

Le calendrier possède maintenant un bouton "P" pour "Paramètres".

Un simple clic dessus "ouvrira" l'accès à un multipage permettant le paramétrage de ce calendrier.

Transportable :

En plus du fait de n'être composé que d'un module, les paramètres seront dorénavant enregistrés, non plus dans le gestionnaire de noms du classeur, mais dans le module lui-même. Ainsi, la configuration choisie sera exportable d'un classeur à un autre...

Toujours efficace sous 2003 et/ou 2010, il conviendra de le tester sous d'autres configurations pour la portabilité d'un Excel vers l'autre...

Par contre, si je viens ici pour vous faire languir, c'est également pour savoir quels seraient les paramètres que vous souhaiteriez pouvoir modifier dans cette nouvelle version?

Pour info, nous pourrons modifier :

  • la couleur BackColor des boutons
  • la couleur ForeColor de police des boutons
  • la couleur BackColor des conteneurs (Frame)
  • la taille des boutons (Width et/ou Height)
  • la police
  • le format de date en sortie

A ce propos, sont prévus, pour l'instant, ces seuls formats de date : "dd/mm/yy", "dd/mm/yyyy", "dd mmmm yyyy", "dddd d mmmm yyyy".

En souhaiteriez vous d'autres?

Dernière question, verriez vous un intérêt à donner la possibilité de changer le séparateur "/"?

Merci d'avance pour vos contributions à ce projet.

Bonjour,

Toutes mes félicitations pour avoir entrepris ce projet ...!!!

Ce sera très utile à beaucoup de personnes ...

A mon humble avis, au sujet des formats Dates, comme tu le sais le format US (mm/dd/yyyy) peut être utilisé dans les entreprises ...

De la même façon, les séparateurs font partie intégrante de la configuration du pays ...

Salut et merci de ta réponse.

Peux tu m'éclairer à ce propos :

De la même façon, les séparateurs font partie intégrante de la configuration du pays ...

Si, en format de sortie, j'indique par exemple : Value = Format(maDate, "dd/mm/yyyy") et que la configuration Windows de l'utilisateur utilise le "-" dans les formats de date, cela signifie que la date s'affichera comme ceci dans le tableur : 22-05-2015?

Re,

Je voulais parler de la propriété Application.International ...

https://msdn.microsoft.com/fr-fr/library/office/ff840213.aspx

Yessss!!

Bien vu James007!

Je n'avais pas pensé utiliser cette propriété...

Je vais mettre ça en œuvre, c'est très juste.

Merci

Bonjour à tous et merci Pikaju de poursuivre ce projet.

Pour ma part j'avais modifié le calendrier de manière à ce que la date choisi soit mise dans une variable publique

Petite question également, la fonction "estferies" sera t' elle toujours d'actualité ?

Travaillant sur un projet d'entreprise assez énorme, j'utilise cette fonction bien pratique dans de nombreux formulaires et sur quelques feuilles de calcul ce qui m'évite de refaire un tableau de jours fériés ^^

Concernant les tests, je pourrai les faire sous 2013.

Bonne journée.

Salut Fred35,

Petite question également, la fonction "estferies" sera t' elle toujours d'actualité ?

Bien sur. La "base" reste la même.

Concernant les tests, je pourrai les faire sous 2013.

Super, merci.

Par contre, il va falloir un peu de patience... Pas avant la semaine prochaine, au mieux... J'ai encore beaucoup de bugs et le débugage est délicat car certains passages de code ne peuvent être "déroulés" en pas à pas...

pijaku a écrit :

Yessss!!

Bien vu James007!

Je n'avais pas pensé utiliser cette propriété...

Je vais mettre ça en œuvre, c'est très juste.

Merci

De rien ...

Je me réjouis par avance de pouvoir ... bientôt .... voir ton application ...!!!

Loin de moi l'idée de te presser ^^

J'ai moi même commencé un projet que je mettrai sur ce forum mais pas avant quelques mois du fait que j'ai d'abord des projets professionnel à finir et que je suis obligé d'apprendre des choses que je ne maitrise pas.

La seule chose que je dirai concernant mon projet pour ne pas mettre moi aussi l'eau à la bouche à certain, c'est que ton calendrier y sera le bienvenu

Loin de moi l'idée de te presser ^^

Et bien en fait, j'ai quasiment fini.

Encore deux trois "bricolages" de dernière minute et je livre...

Ne vous attendez pas à de grandes choses, ça reste de la programmation VBA normale.

Mais ce sera pratique.

Du moins j'ai tendance à le croire...

Voilà.

Je galère encore un peu sur les formats de dates lors d'un retour dans une cellule...

Grrr!

Les dates m'ont toujours occasionné des pertes de cheveux...

Sinon, voici le classeur "test" : https://www.cjoint.com/c/EEwpCtI266C

Voici le module de classe : https://www.cjoint.com/c/EEwpDENQHVZ

Le code d'appel depuis un module standard est :

Sub Usf_Calendrier()
Dim Cal As New Calendrier
MsgBox Cal.Value  'Optional : Left, Top exemple :  Cal.Value(500, 200)
Set Cal = Nothing
End Sub

Car, oui, on peut le positionner dans l'application également en entrant les paramètres optionels Left et Top (cf commentaire du code d'appel).

Comme on instancie avec le mot-clé New, ne pas oublier de le dégager en fin d'utilisation avec Nothing!

Le code du Module de Classe (pour celles et ceux qui n'aiment pas télécharger depuis Internet) :

Attention à bien nommer cette classe : Calendrier

Ou alors changer le type de la variable : Dim cCalYtRpZaert As New Calendrier

Dans les options d'Excel, il faut avoir coché "Accès approuvé au modèle d'objet du projet VBA". (Pour cela, voir dans Options>Centre de gestion de la confidentialité>Paramètres des macros)

Le code nécessite également de cocher deux références :

  • Microsoft Forms 2.0 Object Library,
  • Microsoft Visual Basic For Applications Extensibility 5.3
Option Explicit
'SOURCES
'http://www.developpez.net/forums/d1513990/logiciels/microsoft-office/excel/macros-vba-excel/reunir-userform-module-classe-seul-module-exportable/
'http://www.commentcamarche.net/faq/41159-vba-excel-toutes-versions-controle-calendrier-transposable
'http://www.commentcamarche.net/faq/43807-vba-creation-d-un-userform-dans-un-module-de-classe
'http://forum.excel-pratique.com/excel/calendrier-portable-t57385.html
'http://blog.developpez.com/philben/p11431/vba-access/calculer-la-date-de-paques
'http://blog.developpez.com/philben/p11458/vba-access/sagit-il-dun-jour-ferie
'http://boisgontierjacques.free.fr/

'réalisé en mai 2015 par pijaku
'Version 4.1 : 22/05/2015

'références à cocher :
   ' Microsoft Forms 2.0 Object Library
   ' Microsoft Visual Basic For Applications Extensibility 5.3.

'déclarations, constantes et variables permettant d'inhiber la croix de fermeture de l'userform
#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = 61536
Private Const MF_BYCOMMAND = 0
Dim hwnd&, Style&
'Variables Public et Private de chaque objet instance de la classe = propriétés des instances de classe
Public Usf As Object
Private Nom$
Public Dico As Object
Public FRM As MSForms.Frame
Public Labl As MSForms.Label
Public Txt As MSForms.TextBox
'variables permettant la gestion d'événements (actions sur les contrôles correspondants)
Public WithEvents OpB As MSForms.OptionButton
Public WithEvents Combo As MSForms.ComboBox
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents MultiPage As MSForms.MultiPage
'constantes approximatives non modifiables dues aux "effets de bord" (userform et/ou frame)
Private Const BORD_B As Byte = 12
Private Const BORD_R As Byte = 4
Private Const BORD_FRAME As Byte = 1
'Caption des boutons de commande
Private Const CAPTIONS_BTN_CMD$ = "<<,<,>,>>,P"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NE PAS MODIFIER LES 41 LIGNES CI-DESSOUS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'////DEBUT PARAMETRES
Private Const H_BTN As Byte = 20                            'hauteur des boutons       '0
Private Const W_BTN As Byte = 20                            'largeur des boutons       '0
Private Const W_CMD As Byte = 20                            'largeur des commandes     '0
Private Const H_LAB As Byte = 15                            'hauteur des labels        '0
Private Const MARGE_L As Byte = 1                           'marge gauche              '0
Private Const MARGE_T As Byte = 1                           'marge haut                '0
Private Const FONT_SIZE_LAB As Integer = 12                 'taille police labels      '3
Private Const FONT_SIZE_BTN As Integer = 10                 'taille police boutons     '3
Private Const FONT_SIZE_BTN_CMD As Integer = 8              'taille police commandes   '3
Private Const BC_USF As Long = 14737632                     'fond userform             '1
Private Const BC_F_CMD As Long = 14737632                   'fond commande             '1
Private Const BC_F_JOURS As Long = 14737632                 'fond jours                '1
Private Const BC_CMD As Long = 14737632                     'fond commandes            '2
Private Const FC_CMD As Long = 0                            'couleur police commandes  '4
Private Const F_CMD As String = "Tahoma"                    'police commandes          '3
Private Const BC_LAB As Long = 14737632                     'fond labels               '1
Private Const BC_L As Long = 8438015                        'fond boutons lundi        '2
Private Const BC_Ma As Long = 8438015                       'fond boutons mardi        '2
Private Const BC_Me As Long = 8438015                       'fond boutons mercredi     '2
Private Const BC_J As Long = 8438015                        'fond boutons jeudi        '2
Private Const BC_V As Long = 8438015                        'fond boutons vendredi     '2
Private Const BC_S As Long = 192                            'fond boutons samedi       '2
Private Const BC_D As Long = 192                            'fond boutons dimanche     '2
Private Const BC_F As Long = 8454016                        'fond boutons fériés       '2
Private Const FC_LAB As Long = 0                            'couleur police labels     '4
Private Const FC_Lu As Long = 0                              'couleur police lundi      '4
Private Const FC_Ma As Long = 8388608                       'couleur police mardi      '4
Private Const FC_Me As Long = 0                             'couleur police mercredi   '4
Private Const FC_J As Long = 789516                         'couleur police jeudi      '4
Private Const FC_V As Long = 789516                         'couleur police vendredi   '4
Private Const FC_S As Long = 14211288                       'couleur police samedi     '4
Private Const FC_D As Long = 14211288                       'couleur police dimanche   '4
Private Const FC_F As Long = 0                              'couleur police fériés     '4
Private Const F_LAB As String = "Cambria"                    'police labels             '3
Private Const F_JOURS As String = "Constantia"                  'police jours              '3
Private Const FORM_DATE As String = "dd/mm/yyyy"              'format date               '0
Private Const LIST_FORMATS As String = "dd/mm/yy;dd/mm/yyyy;mm/dd/yyyy;dd mmmm yyyy;dddd d mmmm yyyy" 'liste formats   '0
Private Const LIST_FONTS As String = "Arial;Calibri;Cambria;Comic Sans MS;Constantia;Courier New;Garamond;Georgia;Lucida Calligraphy;Lucida Console;MS Sans Serif;Monotype Corsiva;Tahoma;Times New Roman;Verdana" 'liste fonts '3
'////FIN PARAMETRES
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Dim cCalYtRpZaert As New Calendrier

Private Sub Class_Initialize()
   Set Dico = CreateObject("Scripting.dictionary")
End Sub

Public Function Value(Optional L#, Optional T#)
Dim Liste, Sep$, Jour$, Mois$, Annee$
   Call NewUsf(Format(Date, "mmmm yyyy"), 7 * (W_BTN + MARGE_L) + MARGE_L + 5, MARGE_T * 2 + H_BTN, L, T)
   Liste = Liste_Parametres
   Call Creer_Calendrier(Date, "", Liste)
   Call Usf_Initialize
   Usf.Controls("Btn_Jours" & Day(Date)).SetFocus
   Usf.Show
   On Error GoTo Fin
   Sep = Application.International(xlDateSeparator)
   Value = Format(Usf.Tag & Sep & Month(Usf.Caption) & Sep & Right(Usf.Caption, 4), FORM_DATE)
   Unload Usf
   Exit Function
Fin:
   MsgBox "erreur"
End Function

Private Sub NewUsf(Cap$, W%, H%, Optional L#, Optional T#)
   Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
   Nom = Usf.Name
   VBA.UserForms.Add (Nom)
   Set Usf = UserForms(UserForms.Count - 1)
   With Usf
      .Caption = Cap
      .BackColor = BC_USF
      .StartUpPosition = 0
      If L Then
         .Move L, T
      Else
         .Move (Application.Width - .Width) / 2, (Application.Height - .Height) / 2
      End If
   End With
End Sub

Private Sub NewFrme(Name$, Caption$, Left%, Top%, Width%, Height%, BckCol&)
Dim obj As Object
   Set obj = Usf.Controls.Add("forms.frame.1")
   If TypeName(obj) = "Nothing" Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.FRM = obj
   With cCalYtRpZaert.FRM
      .Name = Name
      .Caption = Caption
      .BackColor = BckCol
      .Move Left, Top, Width, Height
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewBouton(Name$, Caption$, Width%, Height%, Left%, Top%, BckC&, ForeC&, fontSize%, Page%)
Dim obj As Object
   If Page > -1 Then
      Set obj = MultiPage(Page).Controls.Add("forms.CommandButton.1")
   Else
      Set obj = FRM.Controls.Add("forms.CommandButton.1")
   End If
   If obj = True Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.Bouton = obj
   Set cCalYtRpZaert.FRM = FRM
   With cCalYtRpZaert.Bouton
      .Name = Name
      .Caption = Caption
      .Move Left, Top, Width, Height
      .BackColor = BckC
      .ForeColor = ForeC
      .Font.Size = fontSize
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewLabel(Name$, Caption$, Left%, Top%, Width%, Height%, BckC&, ForeC&, fontSize%, Page%)
Dim obj As Object
   If Page > -1 Then
      Set obj = MultiPage(Page).Controls.Add("forms.Label.1")
   Else
      Set obj = FRM.Controls.Add("forms.Label.1")
   End If
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.Labl = obj
   With cCalYtRpZaert.Labl
      .Name = Name
      .Caption = Caption
      .Move Left, Top, Width, Height
      .Object.BackColor = BckC
      .Object.ForeColor = ForeC
      .TextAlign = fmTextAlignCenter
      .Font.Size = fontSize
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewMultiPage(Name$, Left%, Top%, Width%, Height%, Nb%, ParamArray Onglets())
Dim obj As Object, n%, i%
   Set obj = Usf.Controls.Add("forms.MultiPage.1")
   If TypeName(obj) = "Nothing" Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.MultiPage = obj
   n = cCalYtRpZaert.MultiPage.Pages.Count
   n = Nb - n
   For i = 1 To n
      cCalYtRpZaert.MultiPage.Pages.Add
   Next
   For i = 0 To UBound(Onglets)
      cCalYtRpZaert.MultiPage.Pages(i).Caption = CStr(Onglets(i))
   Next
   With cCalYtRpZaert.MultiPage
      .Name = Name
      .Move Left, Top, Width, Height
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewOptBout(Name$, Caption$, Left%, Top%, Width%, Height%, cTag$, Optional Page%)
Dim obj As Object
   Set obj = MultiPage(Page).Controls.Add("forms.OptionButton.1")
   If obj = True Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.OpB = obj
   With cCalYtRpZaert.OpB
      .Name = Name
      .Caption = Caption
      .Tag = cTag
      .Move Left, Top, Width, Height
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewTextB(Name$, Vis As Boolean, Trans%, Page%, L%, T%, W%, H%, Bloquee As Boolean, Ena As Boolean)
Dim obj As Object
   If Page > -1 Then
      Set obj = MultiPage(Page).Controls.Add("forms.TextBox.1")
   Else
      Set obj = FRM.Controls.Add("forms.TextBox.1")
   End If
   If obj = True Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.Txt = obj
   With cCalYtRpZaert.Txt
      .Name = Name
      .Visible = Vis
      .BackStyle = Trans
      .Move L, T, W, H
      .Locked = Bloquee
      .Enabled = Ena
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Public Sub NewCombo(Name$, Liste, Left%, Top%, Width%, Height%, Page%)
Dim obj As Object
   Set obj = MultiPage(Page).Controls.Add("forms.ComboBox.1")
   If obj = True Then Exit Sub
   Set cCalYtRpZaert.Usf = Usf
   Set cCalYtRpZaert.Combo = obj
   With cCalYtRpZaert.Combo
      .Name = Name
      .List = Liste
      .Move Left, Top, Width, Height
   End With
   Dico.Add Name, cCalYtRpZaert
   Set cCalYtRpZaert = Nothing
End Sub

Private Sub Usf_Initialize()
Dim hSysMenu&, MeHwnd&
    MeHwnd = FindWindowA(vbNullString, Usf.Caption)
    If MeHwnd > 0 Then
        hSysMenu = GetSystemMenu(MeHwnd, False)
        RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
    Else
        MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
    End If
End Sub

Private Sub Creer_Calendrier(dte As Date, Simul$, Liste)
Dim i%, W%, H%, Haut%, Cap$, Maxi%, Ctrl As Control
   W = 7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R
   H = CInt(Liste(0, 3)) + BORD_R + CInt(Liste(5, 3)) * 2
   NewFrme "Commandes" & Simul, "", 0, 0, W, H, CLng(Liste(10, 3))
   For i = 1 To 5
      Cap = CStr(Split(CAPTIONS_BTN_CMD, ",")(i - 1))
      Dico("Commandes" & Simul).NewBouton "Btn_Cmd" & i, Cap, CInt(Liste(2, 3)), CInt(Liste(0, 3)), (W / 5) * (i - 1) + CInt(Liste(4, 3)), CInt(Liste(5, 3)), CLng(Liste(12, 3)), CInt(Liste(13, 3)), CInt(Liste(8, 3)), -1
   Next
   Call Creer_Jours(Date, Haut, Simul, Liste)
   With Usf '-------------------------------------------------------- A REVOIR TAILLES USERFORM EN MODE "SIMUL"
      If Simul = "" Then
         .Controls("Jours").Height = Haut + H_BTN + BORD_B
         .Width = W + BORD_R
         .Height = H + Haut + H_BTN + BORD_B + BORD_B
      Else
         For Each Ctrl In .Controls
            If TypeOf Ctrl Is MSForms.OptionButton Then
               If Ctrl.Top > Maxi Then Maxi = Ctrl.Top
            End If
         Next
         .Controls("Jours" & Simul).Height = Haut + CInt(Liste(0, 3)) + BORD_B
         .Controls("Jours" & Simul).Width = W
         .Width = W + BORD_R + 320
         If .Controls("Jours" & Simul).Height > Maxi Then Maxi = .Controls("Jours" & Simul).Height + .Controls("Jours" & Simul).Top
         .Height = Maxi + 30
      End If
   End With
End Sub

Private Sub Creer_Jours(dte As Date, Haut%, Simul$, Liste)
Dim i%, NbJ As Byte, d As Date, G%, BckC&, ForeC&, Cap$
   NewFrme "Jours" & Simul, "", 0, CInt((CInt(Liste(0, 3)) + BORD_R + CInt(Liste(5, 3)) * 2) - BORD_FRAME), CInt(7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R), CInt(Liste(0, 3)), CLng(Liste(11, 3))
   For i = 1 To 7
      Cap = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1))
      Dico("Jours" & Simul).NewLabel "Lab" & i, Cap, CInt(CInt(Liste(4, 3)) + (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) * (i - 1)), CInt(Liste(5, 3)), CInt(Liste(1, 3)), CInt(Liste(3, 3)), CLng(Liste(15, 3)), CLng(Liste(24, 3)), CInt(Liste(6, 3)), -1
   Next i
   NbJ = Day(DateSerial(Year(dte), Month(dte) + 1, 1) - 1)
   Haut = CInt(Liste(5, 3)) + CInt(Liste(3, 3)) + CInt(Liste(5, 3))
   For d = DateSerial(Year(dte), Month(dte), 1) To DateSerial(Year(dte), Month(dte), NbJ)
      Select Case Weekday(d, vbMonday)
         Case 1: G = CInt(Liste(4, 3)): BckC = CLng(Liste(16, 3)): ForeC = CLng(Liste(25, 3)): If Day(d) <> 1 Then Haut = Haut + CLng(Liste(0, 3)) + CLng(Liste(5, 3))
         Case 2: G = CInt(Liste(4, 3)) * 2 + CInt(Liste(1, 3)): BckC = CLng(Liste(17, 3)): ForeC = CLng(Liste(26, 3))
         Case 3: G = CInt(Liste(4, 3)) + CInt((Liste(4, 3)) + CInt(Liste(1, 3))) * 2: BckC = CLng(Liste(18, 3)): ForeC = CLng(Liste(27, 3))
         Case 4: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 3: BckC = CLng(Liste(19, 3)): ForeC = CLng(Liste(28, 3))
         Case 5: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 4: BckC = CLng(Liste(20, 3)): ForeC = CLng(Liste(29, 3))
         Case 6: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 5: BckC = CLng(Liste(21, 3)): ForeC = CLng(Liste(30, 3))
         Case 7: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 6: BckC = CLng(Liste(22, 3)): ForeC = CLng(Liste(31, 3))
      End Select
      If EstJourFerie(Year(d), d) Or Paques(Year(d)) = d Then BckC = CLng(Liste(23, 3)): ForeC = CLng(Liste(32, 3))
      Dico("Jours" & Simul).NewBouton "Btn_Jours" & Day(d), CStr(Day(d)), CInt(Liste(1, 3)), CInt(Liste(0, 3)), G, Haut, BckC, ForeC, CInt(Liste(7, 3)), -1
   Next d
End Sub

Private Sub Creer_Parametres(dte As Date, Optional Page$)
Dim ListParam, i%, Cible$, cNom$, cCap$, cPage%, cVal$, X(4), Maxi%, ListF
   ListParam = Liste_Parametres
   Call Creer_Calendrier(dte, "S", ListParam)
   Dico("JoursS").NewTextB "Cadre", False, 0, -1, 1, 1, 1, 1, False, True
   NewMultiPage "Params", Usf.Controls("JoursS").Width, 0, 320, Usf.Height, 5, "General", "Couleur conteneurs", "Couleur Boutons", "Font Style", "Font Color"
   For i = 0 To 34
      Dico("Params").NewOptBout CStr(ListParam(i, 0)), CStr(ListParam(i, 1)), 0, MARGE_T + 10 + X(CInt(ListParam(i, 2))), 160, 15, Replace(CStr(ListParam(i, 3)), """", ""), CInt(ListParam(i, 2))
      X(ListParam(i, 2)) = X(ListParam(i, 2)) + 15
   Next
   Dico("Params").NewLabel "LFormDate", "Format :", 0, X(0) + 15, 100, 14, BC_USF, FC_LAB, 10, 0
   Dico("Params").NewLabel "LFormFonts", "Polices :", 0, X(3) + 15, 100, 14, BC_USF, FC_LAB, 10, 3
   ListF = Split(LIST_FORMATS, ";")
   Dico("Params").NewCombo "ComboFormat", ListF, 0, X(0) + 30, 100, 20, 0
   ListF = Split(LIST_FONTS, ";")
   Call tri(ListF, LBound(ListF), UBound(ListF))
   Dico("Params").NewCombo "ComboFonts", ListF, 0, X(3) + 30, 100, 20, 3
   For i = 0 To 3
      If X(i) > X(i + 1) Then Maxi = X(i) Else Maxi = X(i + 1)
   Next i
   For i = 0 To 4
      Dico("Params").NewBouton "Croix" & i, "X", 20, 20, 290, 0, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
      If i <> 1 And i <> 2 And i <> 4 Then
         Dico("Params").NewBouton "VALID" & i, "Valider", 60, 20, 185, 45, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
      Else
         Dico("Params").NewBouton "VALID" & i, "OK", 20, 20, 250, 20, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
      End If
      Dico("Params").NewLabel "Lancien" & i, "Ancien :", 120, 5, 60, 14, BC_USF, FC_LAB, 10, i
      Dico("Params").NewTextB "Ancien" & i, True, 1, i, 120, 20, 60, 20, True, False
      Dico("Params").NewLabel "Lnouveau" & i, "Nouveau :", 185, 5, 60, 14, BC_USF, FC_LAB, 10, i
      Dico("Params").NewTextB "Nouveau" & i, True, 1, i, 185, 20, 60, 20, False, True
      Dico("Params").NewLabel "LCache" & i, "", 0, 0, 0, 0, BC_USF, FC_LAB, 10, i
      If i = 1 Or i = 2 Or i = 4 Then Call CreerBoutonsCouleurs(i)
   Next i
   With Usf
      .Controls("Params").Height = Maxi + 60
      If .Height < .Controls("Params").Height Then
         .Height = .Controls("Params").Height
      End If
   End With
   If Page <> "" Then Usf.Controls("Params").Value = CInt(Page)
End Sub

Private Sub CreerBoutonsCouleurs(P%)
Dim i%, Coul, List$, X%, Y%, Cpt%
   List = "16777215;12632319;12640511;12648447;12648384;16777152;16761024;16761087;14737632;8421631;8438015;8454143;8454016;16777088;16744576;16744703;12632256;255;33023;65535;65280;16776960;16711680;16711935;8421504;192;16576;49344;49152;12632064;12582912;12583104;4210752;128;16512;32896;32768;8421376;8388608;8388736;0;64;4210816;16448;16384;4210688;4194304;4194368"
   Coul = Split(List, ";")
   X = 120
   Y = 30
   For i = 0 To UBound(Coul)
      If i Mod 8 = 0 Then X = 120: Y = Y + 15: Cpt = 0
      Dico("Params").NewBouton "Btn_Coul" & P & i, "", 15, 15, X + (15 * Cpt), Y, CLng(Coul(i)), 0, 10, P
      Cpt = Cpt + 1
   Next
End Sub

Private Sub Bouton_Click()
Dim maDate As Date, P%, Anc$, Nouv$, Liste, Quoi$, Ctrl As Control
   Select Case True
      Case Usf.Caption = "Paramètres"
         P = Usf.Controls("Params").SelectedItem.Index
         For Each Ctrl In Usf.Controls("Params")(P).Controls
            If TypeOf Ctrl Is MSForms.OptionButton Then
               If Ctrl.Value = True Then
                  Quoi = Ctrl.Name
               End If
            End If
         Next Ctrl
         Select Case Bouton.Caption
            Case "X"
               SupprTousControles "Parametres"
               Usf.Caption = Format(Date, "mmmm yyyy")
               Liste = Liste_Parametres
               Creer_Calendrier Date, "", Liste
            Case "Valider", "OK"
               If Quoi = "" Then
                  If P = 0 And Usf.Controls("ComboFormat") <> "" Then
                     Quoi = "FORM_DATE"
                  Else
                     GoTo Fin
                  End If
               End If
               Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value
               Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value
               If Nouv = "" Then Exit Sub
               Nouv = Replace(Nouv, """", "")
               Call Verif_Valeur(Nouv, Quoi, Anc)
               SupprTousControles "Parametres"
               Usf.Caption = "Paramètres"
               Creer_Parametres Date, CStr(P)
            Case ""
               If Quoi = "" Then GoTo Fin
               If Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = "" Then Exit Sub
               Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Bouton.BackColor
               Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value
               Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value
               Call Simulation(P, Quoi)
               Call ModifieConst(P, Quoi, Anc, Nouv)
               SupprTousControles "Parametres"
               Usf.Caption = "Paramètres"
               Creer_Parametres Date, CStr(P)
         End Select
      Case Else
         Select Case Bouton.Caption
            Case "<<": ChangeCaptionUsf 0, -1
            Case "<": ChangeCaptionUsf -1, 0
            Case ">": ChangeCaptionUsf 1, 0
            Case ">>": ChangeCaptionUsf 0, 1
            Case "P"
               maDate = CDate("1 " & Usf.Caption)
               SupprTousControles "Calendrier"
               Usf.Caption = "Paramètres"
               Creer_Parametres maDate
            Case Else
               Usf.Tag = Right("0" & Bouton.Caption, 2)
               Usf.Hide
         End Select
   End Select
   Exit Sub
Fin:
MsgBox "Vous devez préalablement sélectionner un paramètre à modifier", vbInformation
End Sub

Private Sub Bouton_MouseMove(ByVal Button%, ByVal Shift%, ByVal X As Single, ByVal Y As Single)
Dim maDate As Date
   If Usf.Caption = "Paramètres" Then
      If Bouton.Caption = "X" Then Bouton.ControlTipText = "Fermeture"
      If Bouton.Caption = "OK" Then Bouton.ControlTipText = "Validation des saisies manuelles"
      If Bouton.Caption = "Valider" Then Bouton.ControlTipText = "Validation"
      Exit Sub
   End If
   If FRM.Name <> "Jours" Then Exit Sub
   If Bouton.Caption = "<<" Or Bouton.Caption = "<" Or Bouton.Caption = ">" Or Bouton.Caption = ">>" Or Bouton.Caption = "P" Or Bouton.Caption = "" Then Exit Sub
   maDate = CDate(Bouton.Caption & "/" & Usf.Caption)
   If EstJourFerie(Year(maDate), maDate) Or Paques(Year(maDate)) = maDate Then Bouton.ControlTipText = QuelFerie(maDate)
End Sub

Private Sub OpB_Click()
Dim Diff%, ListParam
   ListParam = Liste_Parametres
   If OpB = True Then
      Diff = CInt(ListParam(5, 3)) * 2 + CInt(ListParam(3, 3))
      Select Case OpB.Caption
         'MoveCadre(Width%, Height%, Left%, Top%, Vis As Boolean)
         Case "fond labels", "couleur police labels": MoveCadre Usf.Controls("JoursS").Width, CInt(ListParam(3, 3)), 0, 0, True
         Case "fond boutons lundi", "couleur police lundi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, 0, Diff, True
         Case "fond boutons mardi", "couleur police mardi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Diff, True
         Case "fond boutons mercredi", "couleur police mercredi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (ListParam(1, 3) + CInt(ListParam(4, 3))) * 2, Diff, True
         Case "fond boutons jeudi", "couleur police jeudi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 3, Diff, True
         Case "fond boutons vendredi", "couleur police vendredi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 4, Diff, True
         Case "fond boutons samedi", "couleur police samedi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 5, Diff, True
         Case "fond boutons dimanche", "couleur police dimanche": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 6, Diff, True
         Case Else: MoveCadre 0, 0, 0, 0, False
      End Select
      Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = OpB.Tag
   End If
End Sub

Private Sub Combo_Click()
Dim i%, Cible$, Fin$, Liste, Ctrl As Control
   If Combo.Value = "" Then Exit Sub
   Liste = Liste_Parametres
   Select Case Combo.Name
      Case "ComboFormat"
         For Each Ctrl In Usf.Controls("Params")(Usf.Controls("Params").SelectedItem.Index).Controls
            If TypeOf Ctrl Is MSForms.OptionButton Then
               If Ctrl.Value = True Then Ctrl.Value = False
            End If
         Next Ctrl
         Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = Replace(Liste(35, 3), """", "")
         Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Combo.Value
      Case "ComboFonts"
         If Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = "" Then
            MsgBox "Vous devez préalablement choisir une option à modifier", vbInformation
            Exit Sub
         End If
         If IsNumeric(Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value) Then
            MsgBox "Ce type de paramètre n'admet pas cette valeur. " & vbCrLf & _
                     "Merci de saisir une valeur numérique dans le champ de saisie NOUVEAU.", vbInformation
            Combo.Value = ""
            Exit Sub
         End If
         Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Combo.Value
         Combo.Value = ""
   End Select
   Exit Sub
Fin:
   MsgBox "La constante de format de date FORM_DATE a été effacée!", vbCritical
End Sub

Private Sub MultiPage_Change()
   MoveCadre 0, 0, 0, 0, False
End Sub

Private Sub Class_Terminate()
Dim i%, VBComp As VBComponent
    Set Dico = Nothing
    If Nom <> "" Then
        Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
        ThisWorkbook.VBProject.VBComponents.Remove VBComp
    End If
End Sub

Private Sub ChangeCaptionUsf(m%, Y%)
Dim Cap$, maDate As Date, Haut%, Liste
   Cap = Usf.Caption
   maDate = CDate(1 & " " & Cap)
   maDate = DateSerial(Year(maDate) + Y, Month(maDate) + m, 1)
   Usf.Caption = Format(maDate, "mmmm yyyy")
   Call RemoveBoutonsJours
   Liste = Liste_Parametres
   Call Creer_Jours(maDate, Haut, "", Liste)
   Usf.Controls("Jours").Height = Haut + H_BTN + BORD_B
   Usf.Height = Usf.Controls("Jours").Height + Usf.Controls("Jours").Top + BORD_B
End Sub

Private Sub RemoveBoutonsJours()
   Usf.Controls.Remove "Jours"
   Set Dico("Jours") = Nothing
   Dico.Remove "Jours"
End Sub

Private Sub SupprTousControles(Duquel$)
   Select Case Duquel
      Case "Parametres"
         Usf.Controls.Remove "JoursS"
         Set Dico("JoursS") = Nothing
         Dico.Remove "JoursS"
         Usf.Controls.Remove "CommandesS"
         Set Dico("CommandesS") = Nothing
         Dico.Remove "CommandesS"
         Usf.Controls.Remove "Params"
         Set Dico("Params") = Nothing
         Dico.Remove "Params"
      Case "Calendrier"
         Usf.Controls.Remove "Jours"
         Set Dico("Jours") = Nothing
         Dico.Remove "Jours"
         Usf.Controls.Remove "Commandes"
         Set Dico("Commandes") = Nothing
         Dico.Remove "Commandes"
      Case "Simulation"
         Usf.Controls.Remove "JoursS"
         Set Dico("JoursS") = Nothing
         Dico.Remove "JoursS"
         Usf.Controls.Remove "CommandesS"
         Set Dico("CommandesS") = Nothing
         Dico.Remove "CommandesS"
   End Select
End Sub

Private Sub MoveCadre(Width%, Height%, Left%, Top%, Vis As Boolean)
   Usf.Controls("Cadre").Move Left, Top, Width, Height
   Usf.Controls("Cadre").Visible = Vis
End Sub

Private Function Liste_Parametres() As Variant()
Dim i%, Cible$, Cpt%, ListParam(37, 3)
   'Source : http://excel.developpez.com/faq/index.php?page=VBA#RemplacerMotVBE
   With ActiveWorkbook.VBProject.VBComponents("Calendrier").CodeModule
      Do
         i = i + 1
         Cible = .Lines(i, 1)
      Loop While Cible <> "'////DEBUT PARAMETRES"
      i = i + 1
      Do
         Cible = .Lines(i, 1)
         If Cible = "'////FIN PARAMETRES" Then Exit Do
         ListParam(Cpt, 0) = Mid(Cible, InStr(Cible, "Const") + 6, InStr(Cible, "As") - (InStr(Cible, "Const") + 7)) 'nom de la constante
         ListParam(Cpt, 1) = Trim(Split(Cible, "'")(1))                                                              'Caption OpB
         ListParam(Cpt, 2) = CInt(Split(Cible, "'")(2))                                                              'Page du multipage
         ListParam(Cpt, 3) = Trim(Split(Split(Cible, "'")(0), "=")(1))                                               'valeur de la constante
         Cpt = Cpt + 1
         i = i + 1
      Loop
   End With
   Liste_Parametres = ListParam
End Function

Private Sub Simulation(P%, Quoi$)
Dim i%, ListParam, maVal
   ListParam = Liste_Parametres
   maVal = Usf.Controls("Nouveau" & P).Value
   For i = 0 To 37
      If CStr(Quoi) = CStr(ListParam(i, 0)) Then
         ListParam(i, 3) = maVal
         Exit For
      End If
   Next i
End Sub

Private Sub ModifieConst(P%, Quoi$, Ancien$, Nouveau$)
Dim i%, Cible$
   With ActiveWorkbook.VBProject.VBComponents("Calendrier").CodeModule
      Do
         i = i + 1
         Cible = .Lines(i, 1)
      Loop While Cible <> "'////DEBUT PARAMETRES"
      i = i + 1
      Do
         Cible = .Lines(i, 1)
         If Cible = "'////FIN PARAMETRES" Then Exit Do
         If Cible Like "Private Const " & Quoi & "*" Then
            Cible = Replace(Cible, Ancien, Nouveau)
            .ReplaceLine i, Cible
         End If
         i = i + 1
      Loop
   End With
End Sub

Private Sub Verif_Valeur(maVal$, Quoi$, Anc$)
Dim ListParam, ListF, i%, Trouve As Boolean, Nouv$, Modif As Boolean
   Select Case Quoi
      Case "": Exit Sub
      Case "H_BTN", "W_BTN", "W_CMD", "H_LAB"                           '-taille des boutons et labels
         If test_1(maVal, Anc) Then test_2 maVal, Anc, 10, 60
      Case "MARGE_L", "MARGE_T"                                         '-marges
         If test_1(maVal, Anc) Then test_2 maVal, Anc, 0, 10
      Case "FONT_SIZE_LAB", "FONT_SIZE_BTN", "FONT_SIZE_BTN_CMD"        '-taille police
         If test_1(maVal, Anc) Then test_2 maVal, Anc, 6, 20
      Case "F_LAB", "F_JOURS", "F_CMD"                                  '-polices
         If Police_Exist(maVal) Then
            ListParam = Liste_Parametres
            ListF = Split(LIST_FONTS, ";")
            Trouve = False
            For i = 0 To UBound(ListF)
               If CStr(ListF(i)) = maVal Then Trouve = True: Exit For
            Next i
            If Trouve = False Then
               ReDim Preserve ListF(UBound(ListF) + 1)
               ListF(UBound(ListF)) = maVal
               Call tri(ListF, LBound(ListF), UBound(ListF))
               Nouv = Join(ListF, ";")
               ModifieConst Usf.Controls("Params").SelectedItem.Index, "LIST_FONTS", CStr(ListParam(37, 3)), """" & Nouv & """"
               ModifieConst Usf.Controls("Params").SelectedItem.Index, Quoi, Anc, maVal
               Modif = True
            End If
         Else
            MsgBox "Police inconnue dans votre système d'exploitation", vbInformation
            maVal = Anc
            Modif = True
         End If
      Case "FORM_DATE"
         ListF = Split(LIST_FORMATS, ";")
         Modif = True
         For i = 0 To UBound(ListF)
            If CStr(ListF(i)) = maVal Then
               MsgBox "Cette modification ne sera prise en compte qu'à partir de la prochaine utilisation", vbInformation
               Modif = False
               Exit For
            End If
         Next i
      Case Else                                                         '-couleurs back et forecolor
         If test_1(maVal, Anc) Then test_2 maVal, Anc, 0, 2147483647
   End Select
   If Modif = False Then
      Call Simulation(Usf.Controls("Params").SelectedItem.Index, Quoi)
      Call ModifieConst(Usf.Controls("Params").SelectedItem.Index, Quoi, Anc, maVal)
   End If
End Sub

Private Function test_1(maVal$, Anc$) As Boolean
   If Not IsNumeric(maVal) Then
      MsgBox "Cette valeur doit être numérique"
      maVal = Anc
      Exit Function
   End If
   test_1 = True
End Function

Private Sub test_2(maVal$, Anc$, BorneInf&, BorneSup&)
   If Val(maVal) < BorneInf Or Val(maVal) > BorneSup Then
      MsgBox "Cette valeur doit être comprise entre " & BorneInf & " et " & BorneSup
      maVal = Anc
   End If
End Sub

Private Function Police_Exist(myNom$) As Boolean
    On Error Resume Next
    With New StdFont
        .Name = myNom
        Police_Exist = (StrComp(myNom, .Name, vbTextCompare) = 0)
        myNom = .Name
    End With
End Function

Private Function EstJourFerie(ByVal Annee%, ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean
'Philben - v1.0 - 2012 - Free to use
Static dPa As Date, dAs As Date, dPe As Date, bPe As Boolean
Dim a%, m%, j%
   a = Year(laDate): m = Month(laDate): j = Day(laDate)
   Select Case m * 100 + j
      Case 101, 501, 508, 714, 815, 1101, 1111, 1225
         EstJourFerie = True
      Case 323 To 614   '323: Date mini Lundi de Pâques - 614 : Date maxi Lundi de Pentecôte
         If a <> Annee Or EstPentecoteFerie <> bPe Then
            Annee = a: dPa = Paques(a) + 1: dAs = dPa + 38
            bPe = EstPentecoteFerie: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100#
         End If
      Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: EstJourFerie = True: End Select
   End Select
End Function
Private Function Paques(ByVal An%) As Date
'Philben - v1.0 - Free to use
Dim a%, b%, c%, d%, e%, F%
   If An < 10000 Then    'Limite supérieure des dates sous Access (31 décembre 9999)
      Select Case An
         Case 1900 To 2099    'Algorithme de Carter
            a = (204 - 11 * (An Mod 19)) Mod 30 + 22
            Paques = DateSerial(An, 3, a + 6 + (a > 49) - (An + An \ 4 + a + (a > 49)) Mod 7)
         Case Is > 1582    'Proposé en 1876 dans la revue Nature (dérivé de l'algorithme de Delambre)
            a = An Mod 19: b = An \ 100: c = An Mod 100
            d = (19 * a + b - b \ 4 - (b - (b + 8) \ 25 + 1) \ 3 + 15) Mod 30
            e = (32 + 2 * (b Mod 4) + 2 * (c \ 4) - d - c Mod 4) Mod 7
            F = d + e - 7 * ((a + 11 * d + 22 * e) \ 451) + 114
            Paques = DateSerial(An, F \ 31, F Mod 31 + 1)
         Case Is > 324    'Algorithme de Oudin pour les dates juliennes < 1583 décrit par Claus Tondering
            a = (19 * (An Mod 19) + 15) Mod 30
            Paques = DateSerial(An, 3, 28 + a - (An + An \ 4 + a) Mod 7)
      End Select
   End If
End Function
Private Function QuelFerie(Jour As Date) As String
Dim maDate As Date, a%, m%, j%
   maDate = Paques(Year(Jour))
   Select Case Jour
      Case maDate: QuelFerie = "Dimanche de Pâques": Exit Function
      Case CDate(maDate + 1): QuelFerie = "Lundi de Pâques": Exit Function
      Case CDate(maDate + 50): QuelFerie = "Lundi de Pentecôte": Exit Function
      Case CDate(maDate + 39): QuelFerie = "Jeudi de l'ascension": Exit Function
   End Select
   a = Year(Jour): m = Month(Jour): j = Day(Jour)
   Select Case m * 100 + j
      Case 101: QuelFerie = "Nouvel An": Exit Function
      Case 501: QuelFerie = "Fête du travail": Exit Function
      Case 508: QuelFerie = "Armistice 39-45": Exit Function
      Case 714: QuelFerie = "Fête Nationale": Exit Function
      Case 815: QuelFerie = "Assomption": Exit Function
      Case 1101: QuelFerie = "Toussaint": Exit Function
      Case 1111: QuelFerie = "Armistice 14-18": Exit Function
      Case 1225: QuelFerie = "Noël": Exit Function
   End Select
End Function
Sub tri(a, gauc, droi) ' Quick sort
'http://boisgontierjacques.free.fr/
Dim ref, G, d, Temp
  ref = a((gauc + droi) \ 2)
  G = gauc: d = droi
  Do
    Do While a(G) < ref: G = G + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If G <= d Then
       Temp = a(G): a(G) = a(d): a(d) = Temp
       G = G + 1: d = d - 1
    End If
  Loop While G <= d
  If G < droi Then Call tri(a, G, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Dites moi....

Bonjour,

Fonctionne très bien sous Excel 2013.

Par contre pourquoi inhiber le query_close ?

Concernant le code je regarderai à tête reposée parce que pour le coup il y a eu du boulot de fait.

En tout cas bravo

Il y a quelques petits bugs qui sont en cours de correction.

Pourquoi inhiber le QueryClose?

2 raisons :

  • le calendrier doit retourner une valeur
  • de mémoire, ça plante pitoyablement si on ferme l'userform par la croix (genre une erreur "l'objet invoqué s'est déconnecté" ou quelque chose d'avoisinant...)

Bonjour,

Je voulais juste vous témoigner mon soutien

Je me suis attaché à amélioré un fichier de réservation de salle que j'avais partagé sur le forum afin de me dispenser du module monthview pas accessible à tous.

J'avais pas pensé à ce fil que j'avais pourtant déjà visé...

Moi je suis passé par un userform et un module de classe que j'ai adapté.

pijaku a écrit :

Elle se composera d'un seul Module de Classe. Fini le module Userform + le module de classe.

Je suis intrigué de voir comment tu fais çà ?

A bientôt

Cordialement,

Leakim

Bonjour,

Je suis intrigué de voir comment tu fais çà ?

En créant une classe, tu créées un objet.

Il suffit donc de dire que :

  • ta première instance de classe est un Userform
  • les autres sont des contrôles.
Comment gérer la collection d'objet?

Tout simplement en les plaçant dans des Dictionary (plus souples que les collection).

Le premier sera le Dico de l'userform.

Et tu les "imbriques"...

A la sortie tu obtiens un Userform et tous ses contrôles...

Cf l'exemple ci dessus.

Voilà

Bonjour,

Voici donc la version finale que j'espère sans bugs...

@Fred35 : j'y ai ajouté un paramètre optional : inhib. Réglé à True ou False il inhibe ou pas la croix de fermeture de l'userform )

N'hésitez pas à me faire remonter toutes vos remarques et/ou demande d'ajout et/ou de complément d'infos...

ps : le code est commenté.

Merci Pijaku, je n'avais déjà pas trouvé de bugs dans la version précédente.

J'essaierai dans les prochains jours.

Beau travail en tout cas.

Rechercher des sujets similaires à "calendrier portable"