VBA- Création d'un UserForm dans un Module de Classe

Septembre 2016


Introduction

Comment créer un UserForm comprenant un nombre dynamique de contrôles et être capable de faire en sorte que ces contrôles réagissent à certains événements?

Pour obtenir ce résultat, nous pourrions simplement créer un UserForm et un module de classe. En affectant, à la classe, les contrôles créés dynamiquement dans l'userform, nous pouvons les faire "réagir".
Le but ici sera de n'obtenir au final qu'un seul Module et que la procédure d'appel soit simplifiée, limitée à deux-trois lignes de code.

Méthode utilisée

Nous allons créer l'userform et son module, directement en tant qu'objet, donc grâce à notre Module de Classe.
Cette discussion vous donnera le cheminement et les différents aspects et solutions clairement exposés. Inutile de refaire ici ce qui a été fait dans cette discussion.

Nécessité

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

Pour cela, sous l'éditeur VBA, Menu Outils>Références.

Les codes

Pour l'exemple, on va se contenter de créer un userform contenant deux boutons. Ces deux boutons devront réagir au clic et retourner, dans le code appelant, leur Caption.

Le module de classe

1- créez un module de classe dans votre projet VBA

2- Nommez le PremierExemple (propriété Name de la Classe)
3- insérez y ce code :
Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Nécessite de cocher les deux références suivantes (Menu Outils/Références)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Public maForm As Object                                        'Userform
Public WithEvents Bouton As MSForms.CommandButton              'Bouton
Public Dico As Object                                          'Objet Dictionnary = notre collection d'objets

Private Nom As String         'Nom => permet la construction et la destruction de l'userform

Private Sub Class_Initialize()
'constructeur de la classe
   Set Dico = CreateObject("Scripting.dictionary")
End Sub

Public Function Value()
'La méthode Value de notre Classe permet la construction de l'userform
'et le retour de la valeur
    NewUsf "Mon premier UserForm"  'création de l'userform
    NewBouton "toto", "TOTO", 120, 30, 5, 5  'création du bouton TOTO
    NewBouton "titi", "TITI", 120, 30, 5, 35  'création du bouton TITI
    maForm.Show   'affichage de l'userform
    On Error GoTo fin
    Value = maForm.Tag  'on affecte à notre fonction la valeur contenue dans le Tag de l'userform
    Unload maForm
    Exit Function
fin:
End Function

Private Sub NewUsf(monCaption As String)
'procédure de création de l'userform
    Set maForm = ThisWorkbook.VBProject.VBComponents.Add(3) 
    Nom = maForm.Name
    VBA.UserForms.Add (Nom)
    Set maForm = UserForms(UserForms.Count - 1)
    With maForm
      .Caption = monCaption
      .Width = 150
      .Height = 100
    End With
End Sub

Public Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double)
'Procédure de création d'un contrôle bouton
Dim Obj
    Set Obj = maForm.Controls.Add("forms.CommandButton.1")
    If Obj = True Then Exit Sub
    Dim cls As New PremierExemple
    Set cls.maForm = maForm
    Set cls.Bouton = Obj
    With cls.Bouton
        .Name = Name
        .Caption = Caption
        .Move Left, Top, Width, Height
    End With
    Dico.Add Name, cls
    Set cls = Nothing
End Sub

Private Sub Bouton_Click()
'procédure événementielle du clic sur le bouton
   maForm.Tag = Bouton.Caption
   maForm.Hide
End Sub

Private Sub Class_Terminate()
'destructeur de la classe
   Dim VBComp As VBComponent
   Set Dico = Nothing            'supprime toutes les instances de notre classe => tous les boutons
   If Nom <> "" Then             's'il s'agit de l'userform (seule instance ayant une propriété "Nom" remplie)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom) 'on le cible
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'on le supprime
   End If
End Sub

La procédure côté code appelant

en est grandement simplifiée...
Vous disposez, grâce à votre module de classe d'un userform ET d'une méthode Value. Celle-ci vous est retournée très simplement ou vous le voulez, en utilisant le code d'appel :
Sub test()
Dim MyForm As New PremierExemple
MsgBox MyForm.Value
Set MyForm = Nothing
End Sub

L'intérêt est ici évident. L'utilisateur de notre Userform ou de notre Classe ne se pose pas de question. Il sait quoi faire avec un code du genre maForm.Value. Rien de plus aisé que de placer ce résultat dans une cellule, un textbox ou autre...

Exemple plus complexe : Le jeu du démineur

Dans cet exemple, les boutons seront créés aléatoirement, dans un Frame servant de conteneur au sein même de notre UserForm.
A noter qu'ici, ne retournant pas de valeur, nous ne créerons pas de méthode Value à notre Classe.

Le code appelant

A placer dans un module standard :
Sub Usf_Demineur()
  Dim MyForm As New cDemineur
  MyForm.Show 0 , False
End Sub

Les paramètres de cet userform sont :
- premier paramètre [Obligatoire] : 0, 1 ou 2 représente la difficulté (%age de mines)
- second paramètre [Facultatif] : True ou False = Mode tricheur activé ou non

Le module de classe

1- créez un module de classe dans votre projet VBA

2- Nommez le cDemineur (propriété Name de la Classe)
3- insérez y ce code :
Option Explicit
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Nécessite de cocher les deux références suivantes (Menu Outils/Références)
    'Microsoft Forms 2.0 Object Library
    'Microsoft Visual Basic For Applications Extensibility 5.3
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'Variables publiques
Public maForm As Object                                         'Userform
Public Fram As MSForms.Frame                                    'Frame = conteneur des boutons
Public Dico As Object                                           'Objet dictionary
Public DicoParent As Object                                     'Objet dictionary
Public Mine As Boolean                                          'Propriété Mine si True = bouton piégé
Public Decouverte As Boolean                                    'Propriété Découverte si True = "terrain(bouton) déminé"
'variables privées
Private Nom As String                                           'Nom => permet la construction et la destruction de l'userform
Private cVoisins() As cDemineur                                 'propriété sous forme de tableau listant les boutons voisins
'variables publiques "événementielles"
Public WithEvents Bouton As MSForms.CommandButton               'Bouton
'constantes
Private Const LARG_BTN As Byte = 18                             'taille des boutons
Private Const MIN_LIGN As Byte = 7                              'minimum de lignes
Private Const MAX_LIGN As Byte = 30 - MIN_LIGN                  'maximum de lignes
Private Const MIN_COL As Byte = 7                               'minimum de colonnes
Private Const MAX_COL As Byte = 40 - MIN_COL                    'maximum de colonnes
Private Const POURCENT_SIMPLE As Byte = 10                      '%age de mines en mode facile
Private Const POURCENT_MEDIUM As Byte = 2 * POURCENT_SIMPLE     '%age de mines en mode médium
Private Const POURCENT_HARD As Byte = 3 * POURCENT_SIMPLE       '%age de mines en mode difficile
Private Const COUL_MINE As Long = &H188B0                       'couleur des boutons minés (pour les dévoiler)
Private Const COUL_BOUTON As Long = &H8000000F                  'couleur des boutons
Private Const COUL_MINE_POSSIBLE As Long = &HFFFFFF             'couleur si bouton possiblement miné (bouton affiche ?) => doute
Private Const COUL_MINE_PROB As Long = &H8080FF                 'couleur si bouton probablement miné (bouton affiche !) => attention danger

Property Get Voisins() As cDemineur()                           'propriété de type tableau
'propriété Voisins en Lecture
   Voisins = cVoisins
End Property

Property Let Voisins(ByRef nouvVoisins() As cDemineur)
'propriété Voisins en Ecriture
   cVoisins = nouvVoisins
End Property

Private Sub Class_Initialize()
'constructeur de la classe cDémineur
   Set Dico = CreateObject("Scripting.dictionary")
End Sub

Public Sub Show(ByRef Difficult As Long, Optional ModeTriche As Boolean = False)
'Méthode Show : permet l'affichage de l'Userform
   On Error GoTo ErreurParametresMacros        'Vérification si "accès approuvé au modèle objet du projet VBA" est cochée dans les options Excel
   With ThisWorkbook.VBProject: End With
   Dim Lign As Long, Col As Long, NbLignes As Long, NbColonnes As Long
   Dim NbMines As Long, MineAdress() As String, CptMine As Long
   Randomize Timer                             'initialisation générateur de nombres aléatoires
   NbLignes = Int(MAX_LIGN * Rnd) + MIN_LIGN   'Nombre de lignes de boutons
   NbColonnes = Int(MAX_COL * Rnd) + MIN_COL   'Nombre de colonnes de boutons
   Select Case Difficult                       'Nombre de Mines selon la difficulté choisie
      Case 0: Difficult = POURCENT_SIMPLE
      Case 1: Difficult = POURCENT_MEDIUM
      Case 2: Difficult = POURCENT_HARD
      Case Else: Exit Sub
   End Select
   NbMines = (NbLignes * NbColonnes) * Difficult \ 100
   ReDim MineAdress(NbMines)
   For CptMine = 1 To NbMines                 'coordonnées des Mines : Col-Lig
      MineAdress(CptMine) = Int(NbColonnes * Rnd) + 1 & "-" & Int(NbLignes * Rnd) + 1
   Next
   Call Creation_Usf("Démineur", (NbColonnes * LARG_BTN) + 5, (NbLignes * LARG_BTN) + 22)  'création Userfom
   Call Nouveau_Frame("Fram1", "", NbColonnes * LARG_BTN, NbLignes * LARG_BTN)             'création Frame
   For Lign = 1 To NbLignes                                                                'création Boutons
      For Col = 1 To NbColonnes
         'les noms des boutons : Col-Lig
         Call Dico("Fram1").Nouveau_Bouton(Col & "-" & Lign, "", LARG_BTN * (Col - 1), LARG_BTN * (Lign - 1), EstDans(Col & "-" & Lign, MineAdress), ModeTriche)
         Set Dico("Fram1").Dico(Col & "-" & Lign).DicoParent = Dico("Fram1").Dico
      Next Col
   Next Lign
   maForm.Tag = Timer  'stockage de l'heure de début de partie dans la propriété Tag de l'userform
   maForm.Show         'affichage du démineur
   Exit Sub
ErreurParametresMacros:
   MsgBox "Veuillez vérifier que vous avez approuvé l'accès au modèle objet du projet VBA."
End Sub

Private Sub Creation_Usf(Titre As String, Largeur As Double, Hauteur As Double)
'création Userfom
   Set maForm = ThisWorkbook.VBProject.VBComponents.Add(3)  'on ajoute au projet un module d'userform
   Nom = maForm.Name                                        'on prend son nom
   VBA.UserForms.Add (Nom)                                  'on ajoute l'userform au projet VBA
   Set maForm = UserForms(UserForms.Count - 1)              'on affecte cet userform à notre variable objet
   With maForm                                              'on lui affecte certaines propriétés
      .Caption = Titre                                      'titre
      .Width = Largeur                                      'largeur
      .Height = Hauteur                                     'hauteur
   End With
End Sub

Public Sub Nouveau_Frame(monNom As String, Titre As String, Largeur As Double, Hauteur As Double)
'création Frame
   If Dico.Exists(monNom) = True Then Exit Sub              'si déjà existant on quitte
   Dim maClass As New cDemineur                             'création d'une nouvelle instance de notre classe
   Set maClass.Fram = maForm.Controls.Add("forms.frame.1")  'Création d'un contrôle de type Frame
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   With maClass.Fram                   'on lui affecte certaines propriétés
      .Name = monNom                   'nom
      .Caption = Titre                 'titre
      .Move 0, 0, Largeur, Hauteur     'emplacement
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   Set maClass = Nothing
End Sub

Public Sub Nouveau_Bouton(monNom As String, Titre As String, Gauche As Double, Haut As Double, boolMine As Boolean, Optional ModeTriche As Boolean)
'création Boutons
   If Dico.Exists(monNom) = True Then Exit Sub                       'si déjà existant on quitte
   Dim maClass As New cDemineur                                      'création d'une nouvelle instance de notre classe
   Set maClass.Bouton = Fram.Controls.Add("forms.CommandButton.1")   'Création d'un contrôle de type Bouton
   Set maClass.maForm = maForm         'on affecte l'userform à la propriété "maForm" de notre instance de classe
   maClass.Mine = boolMine             'on définit la propriété Mine de notre bouton (True ou False)
   With maClass.Bouton                 'on définit certaines propriétés du bouton
      .Name = monNom                            'son nom
      .Caption = Titre                          'son Caption
      .Move Gauche, Haut, LARG_BTN, LARG_BTN    'son emplacement
      If ModeTriche Then                           'EN MODE TRICHE, COLORE LES BOUTONS MINES
         If boolMine Then .BackColor = COUL_MINE Else .BackColor = COUL_BOUTON
      Else
         .BackColor = COUL_BOUTON
      End If
   End With
   Dico.Add monNom, maClass            'on ajoute notre instance de classe au Dico
   Set maClass = Nothing
End Sub

Private Function EstDans(adresse As String, Tb) As Boolean
'fonction de recherche d'une valeur dans une var tableau
   Dim i As Long
   For i = 0 To UBound(Tb) 'boucle sur toute la variable tableau passée en paramètre
      If Tb(i) = adresse Then EstDans = True: Exit Function 'si on trouve l'élément cherché => fonction vraie, on sort
   Next i
End Function

Private Sub Bouton_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Procédure événementielle lors de l'appui, à l'aide d'un des 2 boutons de la souris, sur un Bouton de l'Userform
   If Button = XlMouseButton.xlSecondaryButton Then    'clic droit
      Select Case Bouton.Caption 'selon le Caption du bouton 4 possibilités
         Case "": Bouton.Caption = "!": Bouton.BackColor = COUL_MINE_PROB        'si caption est vide : on affiche ! (= attention danger)
         Case "!": Bouton.Caption = "?": Bouton.BackColor = COUL_MINE_POSSIBLE   'si caption est ! : on affiche ? (= doute)
         Case "?": Bouton.Caption = "": Bouton.BackColor = COUL_BOUTON           'si caption est ? : on affiche rien (= levée du doute)
         Case Else:                                                              'sinon (caption = chiffre (Nbre de mines voisines)) On ne fait rien
      End Select
   ElseIf Button = XlMouseButton.xlPrimaryButton Then  'clic gauche
      If DicoParent.Item(Bouton.Name).Mine Then                                  'si bouton miné
         Call Affiche_Toutes_Mines                                               'affichage de toutes les mines
         MsgBox "Partie perdue"                                                  'message PERDU !
         maForm.Hide                                                             'on quitte
      Else                                                                       'si bouton non miné
         Bouton.BackColor = COUL_BOUTON                                          'remet la couleur par défaut en cas de clic droit précédent
         Dim maClass As cDemineur                                                'on appelle la procédure de déminage
         Set maClass = DicoParent.Item(Bouton.Name)                              'procédure récursive de propagation
         Call Demine(maClass)                                                    'des boutons dont les voisins de sont pas des mines
      End If
   End If
   If Partie_Gagnee Then                                                         'lance la fonction Partie_Gagnee
      Call Affiche_Toutes_Mines                                                  'si victoire : affichage des mines et message:
      MsgBox "Félicitations" & vbCrLf & "Partie Gagnée en : " & CInt(Timer - CDbl(maForm.Tag)) & " secondes.", vbOKOnly + vbExclamation, "GAGNE!"
      maForm.Hide                   'on quitte l'userform. Cela déclenche le destructeur de la classe
   End If
End Sub

Private Sub Affiche_Toutes_Mines()
'En cas de partie perdue, colore tous les boutons minés
   Dim cle
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   'celui-ci contient toutes les instances de la classe contenues dans le Frame
      'si l'instance de classe est minée => coloriage
      If DicoParent.Item(cle).Mine Then DicoParent.Item(cle).Bouton.BackColor = COUL_MINE
   Next
End Sub

Private Sub Demine(Cl As cDemineur)
'procédure récursive de propagation de la découverte des boutons non minés
   Dim NbMines As Integer
   NbMines = CompteMines(Cl.Bouton.Name)  'on teste le nombre de mines voisines
   If NbMines > 0 Then                    'si le bouton a au moins une mine parmi ses voisins
      Cl.Bouton.Caption = NbMines         'on affiche ce nombre de mines
      Cl.Decouverte = True                'on découvre ce bouton
   Else                                   'sinon
      If Cl.Decouverte = False Then       'Si le bouton n'est pas déjà découvert
         Cl.Decouverte = True             'on le découvre
         Cl.Bouton.Visible = False        'on le rend la découverte visible par le joueur (=> le bouton disparait)
         Quels_Voisins Cl                 'on cherche qui sont les boutons voisins de ce bouton
         Dim Tb() As cDemineur, i As Integer
         Tb = Cl.Voisins
         For i = 0 To UBound(Tb)          'on démine tous les boutons voisins (RECURSIVITE)
            Demine Tb(i)
         Next
      End If
   End If
End Sub

Private Function CompteMines(Bout As String) As Integer
'fonction comptant les mines contenues dans les boutons voisins
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim maClass As cDemineur
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Bout, "-")(0)) + i                   'incrémentation n° de colonne
         Lig = CInt(Split(Bout, "-")(1)) + j                   'incrémentation n° de ligne
         If DicoParent.Exists(Col & "-" & Lig) Then            'si le bouton existe (évite l'erreur de "débord" de l'userform)
            Set maClass = DicoParent.Item(Col & "-" & Lig)     'on attribue à notre variable le bouton voisin
            If maClass.Mine Then CompteMines = CompteMines + 1 's'il est miné on incrémente notre fonction de 1
         End If
      Next j
   Next i
End Function

Private Sub Quels_Voisins(Cl As cDemineur)
'procédure affectant, à la propriété Voisins() d'un bouton, la liste des boutons qui l'entourent
   Dim i As Integer, j As Integer, Col As Integer, Lig As Integer
   Dim maClass As cDemineur, ListeVoisins() As cDemineur, cpt As Byte
   For i = -1 To 1               'en incrémentant la colonne et la ligne de -1 à 1 on ne "vise" que les
      For j = -1 To 1            'boutons voisins de celui dont le nom est passé en paramètre
         Col = CInt(Split(Cl.Bouton.Name, "-")(0)) + i      'incrémentation n° de colonne
         Lig = CInt(Split(Cl.Bouton.Name, "-")(1)) + j      'incrémentation n° de ligne
         'si le bouton existe et que son nom est différent de celui passé en paramètre (on n'est pas son propre voisin ;-)
         If DicoParent.Exists(Col & "-" & Lig) And Cl.Bouton.Name <> Col & "-" & Lig Then
            Set maClass = DicoParent.Item(Col & "-" & Lig)  'on attribue à notre variable le bouton voisin
            ReDim Preserve ListeVoisins(cpt)                'redimensionnement variable tableau
            Set ListeVoisins(cpt) = maClass                 'on affecte notre instance de classe (bouton) au tableau
            cpt = cpt + 1
         End If
      Next j
   Next i
   Cl.Voisins = ListeVoisins        'on affecte la propriété Voisins de notre instance de classe (de notre bouton)
End Sub

Private Function Partie_Gagnee() As Boolean
   Dim cle
   For Each cle In DicoParent.keys 'boucle sur toutes les clés de notre DicoParent
   '(donc sur toutes les instances de la classe, donc sur tous les boutons)
      'Si le bouton n'est pas "découvert" et qu'il ne contient pas de mine
      If DicoParent.Item(cle).Decouverte = False And DicoParent.Item(cle).Mine = False Then
         Partie_Gagnee = False                                          'alors la partie n'est pas finie
         Exit Function
      End If
   Next
   Partie_Gagnee = True
End Function

Private Sub Class_Terminate()
'destructeur de la classe cDémineur
   Dim VBComp As VBComponent
   Set Dico = Nothing            'supprime toutes les instances de notre classe => tous les boutons
   If Nom <> "" Then             's'il s'agit de l'userform (seule instance ayant une propriété "Nom" remplie)
      Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom) 'on le cible
      ThisWorkbook.VBProject.VBComponents.Remove VBComp     'on le supprime
   End If
End Sub

Enjoy the comments...

Exemple pratique : Un calendrier transportable

Cette méthode nous permet de créer un calendrier transportable dans les versions d'excel supérieures à 97, sans se soucier de connaitre cette version. En effet, les versions antérieures à 2007 admettent le contrôle Calendar et pas le DT Picker, les versions supérieures ou égales à 2007 admettent le DT Picker et plus le contrôle Calendar...
Nous pouvons donc, grâce à ce seul module de classe, disposer d'un calendrier partout...

Note : lien vers la fiche pratique initiale du Calendrier

Code d'appel

A coller dans un module standard :
Option Explicit

'A placer en entête d'un module standard
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Affiche As Boolean

Sub Test_Calendar()
Dim Cal As New Calendrier
Dim maDate As Date
'appel de la procédure (Affiche ==> sert à afficher ou non la barre de fenêtre de l'UserForm)
'si Affiche = False, la date apparait au survol des boutons "jours"
Affiche = True
maDate = Cal.Value(Affiche, True)
'exemples de restitution :
MsgBox maDate
Range("A1") = maDate
End Sub

Le code de la classe nommée Calendrier

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/
'http://vb.developpez.com/faqvba/?page=3.6#UFnotitle

'réalisé en mai 2015 par pijaku : http://www.commentcamarche.net/profile/user/pijaku
    'Version 4.3 : 26/05/2015
    'Version 4.4 : 26/02/2016
    
'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 et/ou la barre de titre 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
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) 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
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Private Const SC_CLOSE = 61536
Private Const MF_BYCOMMAND = 0
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const SWP_FRAMECHANGED = &H20
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 Dicollec As Object
Public Frme 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
Private Const BORD_AFF As Byte = 18
'Caption des boutons de commande
Private Const CAPTIONS_BTN_CMD$ = "<<,<,>,>>,P,X"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 = 20                            '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 = 13                 '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 = 12632256                     'fond userform             '1
Private Const BC_F_CMD As Long = 12632256                   'fond commande             '1
Private Const BC_F_JOURS As Long = 12632256                 '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 = "Cambria"                    'police commandes          '3
Private Const BC_LAB As Long = 12632256                     '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 = 49152                        '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 = 0                         '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 = "Monotype Corsiva"                  'police jours              '3
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
'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
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Dim ClassCalend As New Calendrier

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

Public Function Value(Affich_Barre_Titre As Boolean, Optional Inhib As Boolean, Optional L#, Optional T#) As Date
Dim Liste, Sep$, maDate As Date
   'récupère, via la Function Liste_Parametres, les Private Const paramétres du calendrier
   Liste = Liste_Parametres
   'création de l'userform (Caption, Width, Height et Optional Left et Top)
   Call NewUsf(Format(Date, "mmmm yyyy"), 7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + 5, CInt(Liste(5, 3)) * 2 + CInt(Liste(0, 3)), L, T)
   'Procédure de création des contrôles du Calendrier
   Call Creer_Calendrier(Date, "", Liste, Affich_Barre_Titre)
   'Procédure inhibant la croix de fermeture
   If Affich_Barre_Titre = False Then Call AfficheTitleBarre(Usf.Caption, Affich_Barre_Titre)
   If Inhib = False Then Call Usf_Initialize
   'Attribution du Focus au bouton correspondant à la date du jour
   Usf.Controls("Btn_Jours" & Day(Date)).SetFocus
   'Affichage de l'userform
   Usf.Show
   'le séparateur de date (selon le choix systeme)
   Sep = Application.International(xlDateSeparator)
   'Gestionnaire d'erreur => Si Usf.Tag ne contient rien
   On Error GoTo Fin
   
   '===============================================================================================================
   'Attribution à Value de : Usf.Tag (jour) et Usf.Caption (Mois et Année)
   maDate = IIf(Usf.Tag = "X", Date, CDate(Usf.Tag & Sep & Month(Usf.Caption) & Sep & Right(Usf.Caption, 4)))
   'exemple de modification possible :
   'maDate = Format(maDate, "mm/dd/yyyy")
   Value = maDate
   '===============================================================================================================
   
   'UnLoad l'userform entraine la procédure Class_Terminate
   Unload Usf
   Exit Function
Fin:
   'En cas d'erreur, la valeur de notre calendrier
   Value = CDate(Date)
End Function

Private Sub NewUsf(Cap$, W%, H%, Optional L#, Optional T#)
'procédure de création de l'userform
   Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)     'création de l'userfom
   Nom = Usf.Name                                           'Stockage du nom de l'userform
   VBA.UserForms.Add (Nom)                                  'ajout de l'userfom à la collection Userforms
   Set Usf = UserForms(UserForms.Count - 1)                 'attribution, à la variable Usf, de l'Userform créé
   With Usf                                                 'paramètres de l'userfom
      .Caption = Cap                                           'Caption (date au format mmmm yyyy)
      .BackColor = BC_USF                                      'BackColor
      .StartUpPosition = 0                                     'StartUpPosition
      If L Then                                             'Si les Optional Left et Top sont demandés
         .Move L, T                                            'positionnement de l'userfom ou souhaité
      Else                                                  'Sinon
         .Move (Application.Width - .Width) / 2, (Application.Height - .Height) / 2 'par défaut : centré dans l'application
      End If
   End With
End Sub

Private Sub NewFrme(Name$, Caption$, Left%, Top%, Width%, Height%, BckCol&)
'Procédure de création d'un Frame (conteneur)
Dim obj As Object
   Set obj = Usf.Controls.Add("forms.frame.1")              'Ajout d'un contrôle de type Frame à l'userform
   If TypeName(obj) = "Nothing" Then Exit Sub               'Traitement d'erreur (si un Frame du même nom existe déjà, par exemple)
   Set ClassCalend.Usf = Usf                              'On attribue, à la propriété Usf de notre instance de classe (Frame), l'Userform **
   Set ClassCalend.Frme = obj                             'remplissage de la propriété Frme de notre instance de classe
   With ClassCalend.Frme                                  'propriétés du Frame
      .Name = Name
      .Caption = Caption
      .BackColor = BckCol
      .Move Left, Top, Width, Height
   End With
   Dicollec.Add Name, ClassCalend                         'Ajout de l'instance de Classe à la collection des objets de l'userform
   Set ClassCalend = Nothing                              'Destruction de l'instance "temporaire" à la Classe
End Sub
'** ceci permet "d'attacher" les contrôles à l'userform.
'Sans cette ligne de code, on ne pourrait pas faire réagir
'les contrôles de l'userform en utilisant, par exemple, Usf.Controls("Frame2")

Public Sub NewBouton(Name$, Caption$, Width%, Height%, Left%, Top%, BckC&, ForeC&, fontSize%, Page%)
'Procédure de création d'un bouton de commande
Dim obj As Object
   If Page > -1 Then                                                    'le paramètre d'appel Page permet de savoir si le bouton
      Set obj = MultiPage(Page).Controls.Add("forms.CommandButton.1")   'est inséré dans un multipage (Page = 0 ou +)
   Else
      Set obj = Frme.Controls.Add("forms.CommandButton.1")              'ou dans un Frame (Page = -1)
   End If
   If obj = True Then Exit Sub                                          'Traitement d'erreur (si un bouton du même nom existe déjà, par exemple)
   Set ClassCalend.Usf = Usf                                          'On attribue, à la propriété Usf de notre instance de classe (Bouton), l'Userform
   Set ClassCalend.Bouton = obj                                       'on attribue notre objet à la propriété Bouton (afin de le faire réagir WithEvents)
   Set ClassCalend.Frme = Frme                                        'Attribution propriété Frme
   With ClassCalend.Bouton                                            'propriétés du Bouton de Commande
      .Name = Name
      .Caption = Caption
      .Move Left, Top, Width, Height
      .BackColor = BckC
      .ForeColor = ForeC
      .Font.Size = fontSize
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub
 
Public Sub NewLabel(Name$, Caption$, Left%, Top%, Width%, Height%, BckC&, ForeC&, fontSize%, Page%)
'Procédure de création d'un Label
Dim obj As Object
   If Page > -1 Then
      Set obj = MultiPage(Page).Controls.Add("forms.Label.1")
   Else
      Set obj = Frme.Controls.Add("forms.Label.1")
   End If
   Set ClassCalend.Usf = Usf
   Set ClassCalend.Labl = obj
   With ClassCalend.Labl
      .Name = Name
      .Caption = Caption
      .Move Left, Top, Width, Height
      .Object.BackColor = BckC
      .Object.ForeColor = ForeC
      .TextAlign = fmTextAlignCenter
      .Font.Size = fontSize
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub

Public Sub NewMultiPage(Name$, Left%, Top%, Width%, Height%, Nb%, ParamArray Onglets())
'Procédure de création d'un Multipage (ParamArray Onglets() = Caption des pages du multipage)
Dim obj As Object, n%, i%
   Set obj = Usf.Controls.Add("forms.MultiPage.1")
   If TypeName(obj) = "Nothing" Then Exit Sub
   Set ClassCalend.Usf = Usf
   Set ClassCalend.MultiPage = obj
   n = ClassCalend.MultiPage.Pages.Count
   n = Nb - n
   For i = 1 To n
      ClassCalend.MultiPage.Pages.Add
   Next
   For i = 0 To UBound(Onglets)
      ClassCalend.MultiPage.Pages(i).Caption = CStr(Onglets(i))
   Next
   With ClassCalend.MultiPage
      .Name = Name
      .Move Left, Top, Width, Height
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub

Public Sub NewOptBout(Name$, Caption$, Left%, Top%, Width%, Height%, cTag$, Page%)
'Procédure de création d'un OptionButton
Dim obj As Object
   Set obj = MultiPage(Page).Controls.Add("forms.OptionButton.1")
   If obj = True Then Exit Sub
   Set ClassCalend.Usf = Usf
   Set ClassCalend.OpB = obj
   With ClassCalend.OpB
      .Name = Name
      .Caption = Caption
      .Tag = cTag
      .Move Left, Top, Width, Height
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub
 
Public Sub NewTextB(Name$, Vis As Boolean, Trans%, Page%, L%, T%, W%, H%, Bloquee As Boolean, Ena As Boolean)
'Procédure de création d'un TextBox
Dim obj As Object
   If Page > -1 Then
      Set obj = MultiPage(Page).Controls.Add("forms.TextBox.1")
   Else
      Set obj = Frme.Controls.Add("forms.TextBox.1")
   End If
   If obj = True Then Exit Sub
   Set ClassCalend.Usf = Usf
   Set ClassCalend.Txt = obj
   With ClassCalend.Txt
      .Name = Name
      .Visible = Vis
      .BackStyle = Trans
      .Move L, T, W, H
      .Locked = Bloquee
      .Enabled = Ena
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub

Public Sub NewCombo(Name$, Liste, Left%, Top%, Width%, Height%, Page%)
'Procédure de création d'une Combobox
Dim obj As Object
   Set obj = MultiPage(Page).Controls.Add("forms.ComboBox.1")
   If obj = True Then Exit Sub
   Set ClassCalend.Usf = Usf
   Set ClassCalend.Combo = obj
   With ClassCalend.Combo
      .Name = Name
      .List = Liste
      .Move Left, Top, Width, Height
   End With
   Dicollec.Add Name, ClassCalend
   Set ClassCalend = Nothing
End Sub
 
Private Sub Usf_Initialize()
'Procédure permettant d'inhiber la croix de fermeture de l'userform
'cette procédure peut être "shuntéee", l'erreur étant traitée dans la Function Value
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, Affich_Barre_Titre As Boolean)
'Procédure de création des contrôles du calendrier
   'dte sert dans la procédure de création des boutons Jours
   'Simul permet de différencier si l'on est en mode "paramètre" ou "calendrier"
   'Liste = Liste des paramètres complétée à partir des Private Const
Dim i%, W%, H%, Haut%, Cap$, Maxi%, Wtemp%, Ctrl As Control
   W = 7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R        'calcul du Width de l'userform
   Wtemp = 5 * (CInt(Liste(2, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R
   If Wtemp > W Then W = Wtemp
   H = CInt(Liste(0, 3)) + BORD_R + CInt(Liste(5, 3)) * 2                              'calcul du Height de l'userform
   NewFrme "Commandes" & Simul, "", 0, 0, W, H, CLng(Liste(10, 3))                     'Frame contenant les boutons de commande "<<", ">", ..., ">>", "P".
   For i = 1 To 6                                                                      'Ajout des 5 boutons de commande
      Cap = CStr(Split(CAPTIONS_BTN_CMD, ",")(i - 1))                                  'Caption
      'NewBouton : Name, Caption, Width, Height, Left, Top, BackColor, ForeColor, fontSize, Page
      Dicollec("Commandes" & Simul).NewBouton "Btn_Cmd" & i, Cap, CInt(Liste(2, 3)), CInt(Liste(0, 3)), (W / 6) * (i - 1) + CInt(Liste(4, 3)), CInt(Liste(5, 3)), CLng(Liste(12, 3)), CInt(Liste(13, 3)), CInt(Liste(8, 3)), -1
   Next
   'Lancement de la procédure de création des boutons "jours"
   Call Creer_Jours(Date, Haut, Simul, Liste)
   With Usf 'Dimensionnement de l'userform en fonction de la taille des contrôles
      If Simul = "" Then
         .Controls("Jours").Height = Haut + CInt(Liste(0, 3)) + BORD_B
         .Width = W + BORD_R
         .Height = H + Haut + CInt(Liste(0, 3)) + BORD_B + BORD_B
         If Affiche = False Then Call AfficheTitleBarre(.Caption, Affiche): .Height = .Height - BORD_AFF: .Move .Left, .Top + BORD_AFF
      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
         If Affiche = False Then Call AfficheTitleBarre(.Caption, Affiche): .Height = .Height - BORD_AFF: .Move .Left, .Top + BORD_AFF
      End If
   End With
End Sub

Private Sub Creer_Jours(dte As Date, Haut%, Simul$, Liste)
'Procédure de création des boutons "Jours"
Dim i%, NbJ As Byte, d As Date, G%, BckC&, ForeC&, Cap$
   'création du Frame conteneur
   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 'création des 7 Labels "L", "M", "M" etc
      Cap = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1)) 'Caption
      'NewLabel : Name, Caption, Left, Top, Width, Height, BackColor, ForeColor, fontSize, Page
      Dicollec("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
   'Nombre de jours du mois
   NbJ = Day(DateSerial(Year(dte), Month(dte) + 1, 1) - 1)
   'Haut = Top du premier bouton
   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) 'Calculs : G = Left, BckC = BackColor, ForeC = ForeColor et Haut = top du bouton
         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
      'Si férié
      If EstJourFerie(Year(d), d) Or Paques(Year(d)) = d Then BckC = CLng(Liste(23, 3)): ForeC = CLng(Liste(32, 3))
      'NewBouton : Name, Caption, Width, Height, Left, Top, BackColor, ForeColor, fontSize, Page
      Dicollec("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, Affich_Barre_Titre As Boolean, Optional Page$)
'Procédure de création des contrôles en Mode "paramètres"
Dim ListParam, i%, Cible$, cNom$, cCap$, cPage%, cVal$, x(4), Maxi%, ListF
   'Création du Calendrier en Mode "Simul" afin d'inhiber la procédure Bouton_Click
   ListParam = Liste_Parametres
   Call Creer_Calendrier(dte, "S", ListParam, Affich_Barre_Titre)
   'NewTextB : Name, Visible, Transparence, Page, Left, Top, Width, Height, Locked, Enabled
   Dicollec("JoursS").NewTextB "Cadre", False, 0, -1, 1, 1, 1, 1, False, True 'textbox permettant de repérer les boutons dans le calendrier
   'NewMultiPage : Name, Left, Top, Width, Height, NbPages, Onglets()
   NewMultiPage "Params", Usf.Controls("JoursS").Width, 0, 320, Usf.Height, 5, "General", "Couleur conteneurs", "Couleur Boutons", "Font Style", "Font Color"
   With Dicollec("Params")
      For i = 0 To 34
         'NewOptBout : Name, Caption, Left, Top, Width, Height, Tag, Page
         .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 'X() = propriété Top des OptionButton selon la page
      Next
      '.NewLabel "LFormDate", "Format :", 0, X(0) + 15, 100, 14, BC_USF, FC_LAB, 10, 0
      .NewLabel "LFormFonts", "Polices :", 0, x(3) + 15, 100, 14, BC_USF, FC_LAB, 10, 3
      'ListF = Split(LIST_FORMATS, ";")
      'NewCombo : Name, Liste, Left, Top, Width, Height, Page
      '.NewCombo "ComboFormat", ListF, 0, X(0) + 30, 100, 20, 0
      ListF = Split(LIST_FONTS, ";")
      Call tri(ListF, LBound(ListF), UBound(ListF))
      .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
         'une croix de fermeture sur chaque Page
         .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
            'pour les pages 0 & 3 bouton "Valider"
            .NewBouton "VALID" & i, "Valider", 60, 20, 185, 45, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
         Else
            'pages 1, 2 & 4 Boutons "OK"
            .NewBouton "VALID" & i, "OK", 20, 20, 250, 20, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
         End If
         'pour toutes les pages Labels et TextBox "ancienne valeur" "nouvelle valeur"
         'pour permettre la saisie manuelle de valeurs
         .NewLabel "Lancien" & i, "Ancien :", 120, 5, 60, 14, BC_USF, FC_LAB, 10, i
         .NewTextB "Ancien" & i, True, 1, i, 120, 20, 60, 20, True, False
         .NewLabel "Lnouveau" & i, "Nouveau :", 185, 5, 60, 14, BC_USF, FC_LAB, 10, i
         .NewTextB "Nouveau" & i, True, 1, i, 185, 20, 60, 20, False, True
         .NewLabel "LCache" & i, "", 0, 0, 0, 0, BC_USF, FC_LAB, 10, i
         'pour les pages 1, 2 & 4 création des boutons de couleurs
         If i = 1 Or i = 2 Or i = 4 Then Call CreerBoutonsCouleurs(i)
      Next i
   End With
   With Usf 'Dimensions Userform
      .Controls("Params").Height = Maxi + 60
      If .Height < .Controls("Params").Height Then
         .Height = .Controls("Params").Height
      End If
   End With
   'Ouverture du Multipage soit sur la Page précédemment choisie, soit, par défaut, sur la page 0
   If Page <> "" Then Usf.Controls("Params").Value = CInt(Page)
End Sub

Private Sub CreerBoutonsCouleurs(P%)
'procédure de création des boutons de commande "couleurs"
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  'Left
   y = 30   'top
   For i = 0 To UBound(Coul)
      'Une rangé = 8 boutons
      If i Mod 8 = 0 Then x = 120: y = y + 15: Cpt = 0
      'NewBouton : Name, Caption, Width, Height, Left, Top, BackColor, ForeColor, fontSize, Page
      Dicollec("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()
'Procédure événementielle lors d'un clic sur un bouton
Dim maDate As Date, P%, Anc$, Nouv$, Liste, Quoi$, Ctrl As Control
   Select Case True
      Case Usf.Caption = "Paramètres"  'Mode paramètre
         P = Usf.Controls("Params").SelectedItem.Index         'P = page du multipage "en cours"
         For Each Ctrl In Usf.Controls("Params")(P).Controls   'quel optionButton est sélectionné
            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          'selon le Caption du bouton cliqué
            Case "X"                                           'Cas de la croix
               SupprTousControles "Parametres"                 'on quitte le Mode paramètres
               Usf.Caption = Format(Date, "mmmm yyyy")         'on recrée le calendrier
               Liste = Liste_Parametres
               Creer_Calendrier Date, "", Liste, Affiche
            Case "Valider", "OK"                               'Cas Valider ou Ok
               'If Quoi = "" Then                               'cas particulier du choix de format de date (aucun OptionButton n'est à True)
               '   If P = 0 And Usf.Controls("ComboFormat") <> "" Then   'page = 0 et un choix est fait dans la liste des formats de date
               '      Quoi = "FORM_DATE"
               '   Else
               '      GoTo Fin
               '   End If
               'End If
               Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value      'ancienne valeur
               Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value    'nouvelle valeur
               If Nouv = "" Then Exit Sub    'évite l'erreur si aucune nouvelle valeur n'est saisie (soit manuellement soit par clic sur un bouton couleur)
               Nouv = Replace(Nouv, """", "")      'évite les erreurs dues aux guillemets (String, pas String...)
               Call Verif_Valeur(Nouv, Quoi, Anc)  'procédure de vérification des valeurs saisies
               SupprTousControles "Parametres"     'On relance le mode paramètre
               Usf.Caption = "Paramètres"          'pour actualisation des paramètres du Calendrier
               Creer_Parametres Date, Affiche, CStr(P)
            Case ""                                            'Cas des boutons de couleurs
               If Quoi = "" Then GoTo Fin                      'si aucun optionButton sélectionné
               If Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = "" Then Exit Sub  'si aucune ancienne valeur
               Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Bouton.BackColor    'Complete le textbox "nouvelle valeur"
               Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value   'ancienne valeur
               Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value 'nouvelle valeur
               Call Simulation(P, Quoi)                     'simulation et modification des Private Const
               Call ModifieConst(P, Quoi, Anc, Nouv)
               SupprTousControles "Parametres"              'actualisation des paramètres du Calendrier
               Usf.Caption = "Paramètres"
               Creer_Parametres Date, Affiche, CStr(P)
         End Select
      Case Else            'Mode Calendrier
         Select Case Bouton.Caption
            'cas des boutons de commande
            Case "<<": ChangeCaptionUsf 0, -1, Affiche   'procédure de changement du Caption de l'userform
            Case "<": ChangeCaptionUsf -1, 0, Affiche    '(Caption : mois en cours au format mmmm yyyy)
            Case ">": ChangeCaptionUsf 1, 0, Affiche
            Case ">>": ChangeCaptionUsf 0, 1, Affiche
            Case "P"
               maDate = CDate("1 " & Usf.Caption)  'lancement du mode "paramètres"
               SupprTousControles "Calendrier"
               Usf.Caption = "Paramètres"
               Creer_Parametres maDate, Affiche
            Case "X"
               Usf.Tag = "X"
               Usf.Hide
            Case Else
            'cas des boutons jours
               Usf.Tag = Right("0" & Bouton.Caption, 2) 'on stocke le jour choisi dans le Tag de l'userform
               Usf.Hide                                 'Hide rend la main à la fonction Value
         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)
'Procédure événementielle lors du survol des boutons
Dim maDate As Date
    If Bouton.Caption = "X" Then Bouton.ControlTipText = "Fermeture"
    If Usf.Caption = "Paramètres" Then  'en mode paramètres, affichage d'infos bulles
        If Bouton.Caption = "OK" Then Bouton.ControlTipText = "Validation des saisies manuelles"
        If Bouton.Caption = "Valider" Then Bouton.ControlTipText = "Validation"
        Exit Sub
    End If
    'en mode paramètres on ne fait plus rien sur les boutons jours
    If Frme.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
    'sinon, au survol des boutons jours, en mode calendrier, on affiche une info bulle jour = férié
    maDate = CDate(Bouton.Caption & "/" & Usf.Caption)
    If EstJourFerie(Year(maDate), maDate) Or Paques(Year(maDate)) = maDate Then
        Bouton.ControlTipText = Format(maDate, "dd mmmm yyyy") & " : " & QuelFerie(maDate)
    Else
        Bouton.ControlTipText = Format(maDate, "dd mmmm yyyy")
    End If
End Sub

Private Sub OpB_Click()
'Procédure événementielle lors d'un clic sur un OptionButton
Dim Diff%, ListParam
   ListParam = Liste_Parametres
   If OpB = True Then
      Diff = CInt(ListParam(5, 3)) * 2 + CInt(ListParam(3, 3))
      'dans certains cas, va afficher le textbox permettant de repérer les boutons pour lesquels on va changer les paramètres
      Select Case OpB.Caption
         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()
'Procédure événementielle lors d'un clic sur une ComboBox
Dim i%, Cible$, Fin$, Liste, Ctrl As Control
   If Combo.Value = "" Then Exit Sub
   Liste = Liste_Parametres
   Select Case Combo.Name
      Case "ComboFormat"
         'si on change le format de date, aucun OptionButton ne doit être à true
         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
         'ancienne valeur
         Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = Replace(Liste(35, 3), """", "")
         'nouvelle valeur
         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()
'procédure événementielle lors du changement de page
   MoveCadre 0, 0, 0, 0, False   'rend invisible, éventuellement le cadre de repérage
End Sub

Private Sub Class_Terminate()
'Destructeur de la Classe
Dim i%, VBComp As VBComponent
    Set Dicollec = Nothing    'suppression de toutes les instances de la classe
    If Nom <> "" Then
        'Suppression de l'userform
        Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
        ThisWorkbook.VBProject.VBComponents.Remove VBComp
    End If
End Sub

Private Sub ChangeCaptionUsf(m%, y%, booAffich As Boolean)
'procédure de changement du Caption de l'userform
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 AfficheTitleBarre(Usf.Caption, booAffich)
   Call RemoveBoutonsJours 'suppression des boutons "jours" du mois précédent
   Liste = Liste_Parametres
   Call Creer_Jours(maDate, Haut, "", Liste) 'création des boutons "jours" du mois choisi
   Usf.Controls("Jours").Height = Haut + CInt(Liste(0, 3)) + BORD_B  'ajustement de la taille de l'userform (mois à 4, 5 ou 6 "semaines")
   Usf.Height = Usf.Controls("Jours").Height + Usf.Controls("Jours").Top + BORD_B
   If Affiche = False Then Usf.Height = Usf.Height - BORD_AFF: Usf.Move Usf.Left, Usf.Top + BORD_AFF
End Sub

Private Sub RemoveBoutonsJours()
'supprime tous les CommandButton "Jours"
   Usf.Controls.Remove "Jours"   'suppression du Frame
   Set Dicollec("Jours") = Nothing  'suppression de toutes les instances de Classe contenues dans le Frame
   Dicollec.Remove "Jours"       'suppression de l'instance de classe "Frame jours"
End Sub

Private Sub SupprTousControles(Duquel$)
'suppression des contrôles et/ou instances de classe
   Select Case Duquel
      Case "Parametres"
         Usf.Controls.Remove "JoursS"
         Set Dicollec("JoursS") = Nothing
         Dicollec.Remove "JoursS"
         Usf.Controls.Remove "CommandesS"
         Set Dicollec("CommandesS") = Nothing
         Dicollec.Remove "CommandesS"
         Usf.Controls.Remove "Params"
         Set Dicollec("Params") = Nothing
         Dicollec.Remove "Params"
      Case "Calendrier"
         Usf.Controls.Remove "Jours"
         Set Dicollec("Jours") = Nothing
         Dicollec.Remove "Jours"
         Usf.Controls.Remove "Commandes"
         Set Dicollec("Commandes") = Nothing
         Dicollec.Remove "Commandes"
      Case "Simulation"
         Usf.Controls.Remove "JoursS"
         Set Dicollec("JoursS") = Nothing
         Dicollec.Remove "JoursS"
         Usf.Controls.Remove "CommandesS"
         Set Dicollec("CommandesS") = Nothing
         Dicollec.Remove "CommandesS"
   End Select
End Sub

Private Sub MoveCadre(Width%, Height%, Left%, Top%, Vis As Boolean)
'procédure qui bouge le cadre de repérage
   Usf.Controls("Cadre").Move Left, Top, Width, Height
   Usf.Controls("Cadre").Visible = Vis
End Sub

Private Function Liste_Parametres() As Variant()
'Liste tous les paramètres contenus dans les Private Const
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$)
'remplit une variable tableau en modifiant le paramètre choisi
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$)
'Modification des Private Const
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$)
'procédure de vérification des valeurs saisies
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"                                                  '-format de dates
      '   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
'test si valeur numérique
   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&)
'test si valeur entre bornes
   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
'si police installée dans le système
    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

Sub AfficheTitleBarre(stCaption As String, pbVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
Dim lHwnd As Long
'- Recherche du handle de la fenêtre par son Caption
    lHwnd = FindWindowA(vbNullString, stCaption)
    If lHwnd = 0 Then
        MsgBox "Handle de " & stCaption & " Introuvable", vbCritical
        Exit Sub
    End If
    
    GetWindowRect lHwnd, vrWin
    style = GetWindowLong(lHwnd, GWL_STYLE)
    If pbVisible Then
        SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
    Else
        SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
    End If
    SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
            vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub


A noter : le code de la procédure récursive de propagation de la découverte des boutons non minés a été grandement simplifiée grâce à notre module de classe. Il vous manque une propriété? Créez la dans votre classe! Exemple ici : la propriété Voisins()...

A voir également :

Ce document intitulé «  VBA- Création d'un UserForm dans un Module de Classe  » issu de CommentCaMarche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.