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
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".
-
Merci de ta réponse.
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
-
-
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.-
-
-
-
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 -
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 :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é : CalendrierOption 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)
-
-
bonjour.
c'est possible.
je regarde ça la semaine prochaine
-- -
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 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
-
