Ajouter un bouton de fermeture dans le calendrier
Bernard
-
bernard6907 Messages postés 15 Statut Membre -
bernard6907 Messages postés 15 Statut Membre -
Bonjour,
Je souhaite ajouter un bouton pour fermer le calendrier (car je souhaite supprimer la barre du haut du userform).
J'ai cherché sans y parvenir dans le VBA Excel [toutes versions] - Contrôle calendrier transposable
https://www.commentcamarche.net/faq/41159-vba-excel-toutes-versions-controle-calendrier-transposable
Si quelqu'un a une idée, je l'en remercie par avance
Bernard
Je souhaite ajouter un bouton pour fermer le calendrier (car je souhaite supprimer la barre du haut du userform).
J'ai cherché sans y parvenir dans le VBA Excel [toutes versions] - Contrôle calendrier transposable
https://www.commentcamarche.net/faq/41159-vba-excel-toutes-versions-controle-calendrier-transposable
Si quelqu'un a une idée, je l'en remercie par avance
Bernard
A voir également:
- Ajouter un bouton de fermeture dans le calendrier
- Mon calendrier - Télécharger - Santé & Bien-être
- Ajouter calendrier outlook dans google agenda - Guide
- Ajouter un calendrier sur google agenda - Guide
- Forcer la fermeture d'un programme - Guide
- Impossible d'ajouter un ami sur facebook - Guide
4 réponses
Bonjour Bernard,
Si tu utilises le contrôle donné dans le lien, il convient de ne pas supprimer la barre de titre de l'Userform. En effet, c'est là que s'affiche le nom du mois "en cours".
Si tu utilises le contrôle donné dans le lien, il convient de ne pas supprimer la barre de titre de l'Userform. En effet, c'est là que s'affiche le nom du mois "en cours".
Jai essayé de mettre un label : erreur 13 (incompatibilité de type)
J'ai aussi essayé de le créer dans le Private Sub UserForm_Initialize()
Problème identique.
Costaud le gars qui a créé le calendrier.
J'ai aussi essayé de le créer dans le Private Sub UserForm_Initialize()
Problème identique.
Costaud le gars qui a créé le calendrier.
Apparemment tu es le créateur de ce calendrier.
Chapeau
Il fonctionne merveilleusement bien.
Je l'ai intégré dans plusieurs programmes.
Perso, j'aime bien que les userforms soient dépourvus de barre de titre.
Il est vrai que si tu peux intégrer soit un bouton soit un label pour fermer, c'est formidable.
Merci encore
Chapeau
Il fonctionne merveilleusement bien.
Je l'ai intégré dans plusieurs programmes.
Perso, j'aime bien que les userforms soient dépourvus de barre de titre.
Il est vrai que si tu peux intégrer soit un bouton soit un label pour fermer, c'est formidable.
Merci encore
Merci, ça fait plaisir.
Voici la dernière mouture, en exclusivité pour toi...
Version 4.4
La date s'affiche maintenant au survol de la souris sur les boutons 1, 2, 3, 4 etc
Les deux principales nouveautés sont :
1- plus besoin d'userform, il se créé et se détruit tout seul à chaque utilisation
2- tu peux choisir d'afficher ou non la barre de titre. Pour choisir sans afficher, il suffit d'appeler la méthode Value en lui passant le paramètre False. Comme ceci, par exemple :
Cf dans l'exemple de code d'appel plus bas.
Dans un module Standard :
Dans un module de classe appelé : Calendrier
Et c'est tout...
Le code pour appeler le calendrier est :
IMPORTANT :
Voici la dernière mouture, en exclusivité pour toi...
Version 4.4
La date s'affiche maintenant au survol de la souris sur les boutons 1, 2, 3, 4 etc
Les deux principales nouveautés sont :
1- plus besoin d'userform, il se créé et se détruit tout seul à chaque utilisation
2- tu peux choisir d'afficher ou non la barre de titre. Pour choisir sans afficher, il suffit d'appeler la méthode Value en lui passant le paramètre False. Comme ceci, par exemple :
Dim Cal As New Calendrier Dim maDate As Date maDate = Cal.Value(False)
Cf dans l'exemple de code d'appel plus bas.
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
Dans un module de classe appelé : 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/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 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 = 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 = 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 = "Constantia" '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
Dim Affiche As Boolean
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#)
Dim Liste, Sep$
'récupère, via la Function Liste_Parametres, les Private Const paramétres du calendrier
Liste = Liste_Parametres
Affiche = Affich_Barre_Titre
'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)
Value = IIf(Usf.Tag = "X", Date, Usf.Tag & Sep & Month(Usf.Caption) & Sep & Right(Usf.Caption, 4))
'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 'procédure de changement du Caption de l'userform
Case "<": ChangeCaptionUsf -1, 0 '(Caption : mois en cours au format mmmm yyyy)
Case ">": ChangeCaptionUsf 1, 0
Case ">>": ChangeCaptionUsf 0, 1
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%)
'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, Affiche)
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
Et c'est tout...
Le code pour appeler le calendrier est :
Dim Cal As New Calendrier
Dim maDate As Date
maDate = Cal.Value(False)
MsgBox maDate
'pour afficher la date dans une cellule :
'Range("A1") = maDate
'pour placer la date dans un TextBox1 :
'TextBox1 = maDate
Set Cal = Nothing
IMPORTANT :
'Les 4 paramètres de .Value sont :
'Affich_Barre_Titre As Boolean, Optional Inhib As Boolean, Optional L#, Optional T#
'Affich_Barre_Titre As Boolean ==> Obligatoire
'Valeurs True ou False
'Affiche ou non la barre de titre de l'UserForm calendrier
'Exemple : maDate = Cal.Value(True)
'Optional Inhib As Boolean ==> Optionnel
'Valeurs True ou False
'Inhibe (empêche le clic) ou déshinibe (permet le clic) sur la croix de fermeture de l'UserForm
'Exemple : maDate = Cal.Value(True, True)
'Optional L# ==> Optionnel
'Valeur = Double (Numérique)
'Valeur du Left de l'UserForm par rapport à son parent
'Optional T# ==> Optionnel
'Valeur = Double (Numérique)
'Valeur du Top de l'UserForm par rapport à son parent
'Exemple : maDate = Cal.Value(True, True, 350, 200)
La référence Microsoft forms se coche seule quand tu créées un UserForm. Quand à l'autre, accessibility, elle a du se cocher quand tu as approuvé l'accès au modèle objet VBA.
J'ai repensé à ta demande d'ajouter deux labels. Esthétiquement, ça va beaucoup agrandir le calendrier. Ne préférerais tu pas un seul label qui :
- affiche le mois et l'année en permanence,
- lorsque tu click sur un jour affiche la date correspondant à ton choix,
- lorsque tu click dessus retourne :
==> la date si tu as fait un choix,
==> la date du jour si tu n'as pas choisi de jour et que le mois et l'année du label sont le mois et l'année du jour,
==> le 1er jour du mois présent dans le label pour les autres cas.
--
J'ai repensé à ta demande d'ajouter deux labels. Esthétiquement, ça va beaucoup agrandir le calendrier. Ne préférerais tu pas un seul label qui :
- affiche le mois et l'année en permanence,
- lorsque tu click sur un jour affiche la date correspondant à ton choix,
- lorsque tu click dessus retourne :
==> la date si tu as fait un choix,
==> la date du jour si tu n'as pas choisi de jour et que le mois et l'année du label sont le mois et l'année du jour,
==> le 1er jour du mois présent dans le label pour les autres cas.
--
J'ai trouvé sur https://www.excel-downloads.com/threads/memoriser-microsoft-visual-basic-for-applications-extensibility-5-3.224483/ la possibilité d'activer automatiquement
Sub RefToLibrary()
'OK Sur XL 2013
' create a reference to the VBA Extensibility library.
On Error Resume Next ' in case the reference already exits
ThisWorkbook.VBProject.References _
.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 0
End Sub
Ton avis sur cette procédure
Sub RefToLibrary()
'OK Sur XL 2013
' create a reference to the VBA Extensibility library.
On Error Resume Next ' in case the reference already exits
ThisWorkbook.VBProject.References _
.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 0
End Sub
Ton avis sur cette procédure
Il est vrai que si on supprime la barre de titre on supprime le mois en cours.
Par contre lorsque je me sers des solutions faites par quelqu'un d'autre, j'essaie toujours de les adapter à mon gout perso.
L'avantage de ce calendrier, est qu'il est utilisable sur n'importe quel ordi, quelque soit la config d'EXCEL, sans se préoccuper des datapicker ou autre calendar.
Merci encore pour ta réponse
Après, tu peux effectivement le modifier à ta guise, le code est libre.
Tu pourrais juste à titre d'exemple ajouter un label pour le "mois en cours" qui réagirai au clic pour la fermeture.