Calendrier portable
Bonjour,
De rien. Merci à toi pour avoir lancé ce sujet.
A bientôt
Bonjour,
très beau boulot, j'avais trouvé un site mais les liens de téléchargement ne fonctionnaient plus
puis miracle je retrouve le fichier sur ce site, mais voila
une erreur à l'ouverture du fichier calendrier_portable-3.1.xls apparemment à ma version 64 bit
Erreur de compilation
le code contenu dans ce projet doit être mis à jour pour pouvoir être utilisé sur les systèmes 64 bits vérifiez et mettez à jour les instructions declare, puis marquez-les avec l'attribut PrtSafe
lignes en erreur coté VBA
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
voila je continue a chercher une solution
encore merci pour ce boulot très intéressant
Bonjour,
Une solution pour les systèmes 32 et 64 bytes :
Dans module1
remplacer ce code
Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
par celui-ci :
#If Win64 Then
Public Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
#Else
Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
#End If
Bonjour,
Je bosse actuellement sur la version 4 de ce calendrier.
Cette version se veut :
- plus simple à mettre en œuvre,
- plus intuitive,
- plus transportable.
Simplifications :
Elle se composera d'un seul Module de Classe. Fini le module Userform + le module de classe.
1 seul module = facilité de "transportabilité" d'un classeur à l'autre.
Le code d'appel est également simplifié par la création d'une méthode Value. Ainsi, il suffira de déclarer une variable et d'en appeler la Value, du genre :
Dim myForm As New Calendrier
Debug.Print myForm.Value
Intuitivité :
Le calendrier possède maintenant un bouton "P" pour "Paramètres".
Un simple clic dessus "ouvrira" l'accès à un multipage permettant le paramétrage de ce calendrier.
Transportable :
En plus du fait de n'être composé que d'un module, les paramètres seront dorénavant enregistrés, non plus dans le gestionnaire de noms du classeur, mais dans le module lui-même. Ainsi, la configuration choisie sera exportable d'un classeur à un autre...
Toujours efficace sous 2003 et/ou 2010, il conviendra de le tester sous d'autres configurations pour la portabilité d'un Excel vers l'autre...
Par contre, si je viens ici pour vous faire languir, c'est également pour savoir quels seraient les paramètres que vous souhaiteriez pouvoir modifier dans cette nouvelle version?
Pour info, nous pourrons modifier :
- la couleur BackColor des boutons
- la couleur ForeColor de police des boutons
- la couleur BackColor des conteneurs (Frame)
- la taille des boutons (Width et/ou Height)
- la police
- le format de date en sortie
A ce propos, sont prévus, pour l'instant, ces seuls formats de date : "dd/mm/yy", "dd/mm/yyyy", "dd mmmm yyyy", "dddd d mmmm yyyy".
En souhaiteriez vous d'autres?
Dernière question, verriez vous un intérêt à donner la possibilité de changer le séparateur "/"?
Merci d'avance pour vos contributions à ce projet.
Bonjour,
Toutes mes félicitations pour avoir entrepris ce projet ...!!!
Ce sera très utile à beaucoup de personnes ...
A mon humble avis, au sujet des formats Dates, comme tu le sais le format US (mm/dd/yyyy) peut être utilisé dans les entreprises ...
De la même façon, les séparateurs font partie intégrante de la configuration du pays ...
Salut et merci de ta réponse.
Peux tu m'éclairer à ce propos :
De la même façon, les séparateurs font partie intégrante de la configuration du pays ...
Si, en format de sortie, j'indique par exemple : Value = Format(maDate, "dd/mm/yyyy") et que la configuration Windows de l'utilisateur utilise le "-" dans les formats de date, cela signifie que la date s'affichera comme ceci dans le tableur : 22-05-2015?
Re,
Je voulais parler de la propriété Application.International ...
https://msdn.microsoft.com/fr-fr/library/office/ff840213.aspx
Yessss!!
Bien vu James007!
Je n'avais pas pensé utiliser cette propriété...
Je vais mettre ça en œuvre, c'est très juste.
Merci
Bonjour à tous et merci Pikaju de poursuivre ce projet.
Pour ma part j'avais modifié le calendrier de manière à ce que la date choisi soit mise dans une variable publique
Petite question également, la fonction "estferies" sera t' elle toujours d'actualité ?
Travaillant sur un projet d'entreprise assez énorme, j'utilise cette fonction bien pratique dans de nombreux formulaires et sur quelques feuilles de calcul ce qui m'évite de refaire un tableau de jours fériés ^^
Concernant les tests, je pourrai les faire sous 2013.
Bonne journée.
Salut Fred35,
Petite question également, la fonction "estferies" sera t' elle toujours d'actualité ?
Bien sur. La "base" reste la même.
Concernant les tests, je pourrai les faire sous 2013.
Super, merci.
Par contre, il va falloir un peu de patience... Pas avant la semaine prochaine, au mieux... J'ai encore beaucoup de bugs et le débugage est délicat car certains passages de code ne peuvent être "déroulés" en pas à pas...
pijaku a écrit :Yessss!!
Bien vu James007!
Je n'avais pas pensé utiliser cette propriété...
Je vais mettre ça en œuvre, c'est très juste.
Merci
De rien ...
Je me réjouis par avance de pouvoir ... bientôt .... voir ton application ...!!!
Loin de moi l'idée de te presser ^^
J'ai moi même commencé un projet que je mettrai sur ce forum mais pas avant quelques mois du fait que j'ai d'abord des projets professionnel à finir et que je suis obligé d'apprendre des choses que je ne maitrise pas.
La seule chose que je dirai concernant mon projet pour ne pas mettre moi aussi l'eau à la bouche à certain, c'est que ton calendrier y sera le bienvenu
Loin de moi l'idée de te presser ^^
Et bien en fait, j'ai quasiment fini.
Encore deux trois "bricolages" de dernière minute et je livre...
Ne vous attendez pas à de grandes choses, ça reste de la programmation VBA normale.
Mais ce sera pratique.
Du moins j'ai tendance à le croire...
Voilà.
Je galère encore un peu sur les formats de dates lors d'un retour dans une cellule...
Grrr!
Les dates m'ont toujours occasionné des pertes de cheveux...
Sinon, voici le classeur "test" : https://www.cjoint.com/c/EEwpCtI266C
Voici le module de classe : https://www.cjoint.com/c/EEwpDENQHVZ
Le code d'appel depuis un module standard est :
Sub Usf_Calendrier()
Dim Cal As New Calendrier
MsgBox Cal.Value 'Optional : Left, Top exemple : Cal.Value(500, 200)
Set Cal = Nothing
End Sub
Car, oui, on peut le positionner dans l'application également en entrant les paramètres optionels Left et Top (cf commentaire du code d'appel).
Comme on instancie avec le mot-clé New, ne pas oublier de le dégager en fin d'utilisation avec Nothing!
Le code du Module de Classe (pour celles et ceux qui n'aiment pas télécharger depuis Internet) :
Attention à bien nommer cette classe : Calendrier
Ou alors changer le type de la variable : Dim cCalYtRpZaert As New Calendrier
Dans les options d'Excel, il faut avoir coché "Accès approuvé au modèle d'objet du projet VBA". (Pour cela, voir dans Options>Centre de gestion de la confidentialité>Paramètres des macros)
Le code nécessite également de cocher deux références :
- Microsoft Forms 2.0 Object Library,
- Microsoft Visual Basic For Applications Extensibility 5.3
Option Explicit
'SOURCES
'http://www.developpez.net/forums/d1513990/logiciels/microsoft-office/excel/macros-vba-excel/reunir-userform-module-classe-seul-module-exportable/
'http://www.commentcamarche.net/faq/41159-vba-excel-toutes-versions-controle-calendrier-transposable
'http://www.commentcamarche.net/faq/43807-vba-creation-d-un-userform-dans-un-module-de-classe
'http://forum.excel-pratique.com/excel/calendrier-portable-t57385.html
'http://blog.developpez.com/philben/p11431/vba-access/calculer-la-date-de-paques
'http://blog.developpez.com/philben/p11458/vba-access/sagit-il-dun-jour-ferie
'http://boisgontierjacques.free.fr/
'réalisé en mai 2015 par pijaku
'Version 4.1 : 22/05/2015
'références à cocher :
' Microsoft Forms 2.0 Object Library
' Microsoft Visual Basic For Applications Extensibility 5.3.
'déclarations, constantes et variables permettant d'inhiber la croix de fermeture de l'userform
#If VBA7 Then
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = 61536
Private Const MF_BYCOMMAND = 0
Dim hwnd&, Style&
'Variables Public et Private de chaque objet instance de la classe = propriétés des instances de classe
Public Usf As Object
Private Nom$
Public Dico As Object
Public FRM As MSForms.Frame
Public Labl As MSForms.Label
Public Txt As MSForms.TextBox
'variables permettant la gestion d'événements (actions sur les contrôles correspondants)
Public WithEvents OpB As MSForms.OptionButton
Public WithEvents Combo As MSForms.ComboBox
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents MultiPage As MSForms.MultiPage
'constantes approximatives non modifiables dues aux "effets de bord" (userform et/ou frame)
Private Const BORD_B As Byte = 12
Private Const BORD_R As Byte = 4
Private Const BORD_FRAME As Byte = 1
'Caption des boutons de commande
Private Const CAPTIONS_BTN_CMD$ = "<<,<,>,>>,P"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NE PAS MODIFIER LES 41 LIGNES CI-DESSOUS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'////DEBUT PARAMETRES
Private Const H_BTN As Byte = 20 'hauteur des boutons '0
Private Const W_BTN As Byte = 20 'largeur des boutons '0
Private Const W_CMD As Byte = 20 'largeur des commandes '0
Private Const H_LAB As Byte = 15 'hauteur des labels '0
Private Const MARGE_L As Byte = 1 'marge gauche '0
Private Const MARGE_T As Byte = 1 'marge haut '0
Private Const FONT_SIZE_LAB As Integer = 12 'taille police labels '3
Private Const FONT_SIZE_BTN As Integer = 10 'taille police boutons '3
Private Const FONT_SIZE_BTN_CMD As Integer = 8 'taille police commandes '3
Private Const BC_USF As Long = 14737632 'fond userform '1
Private Const BC_F_CMD As Long = 14737632 'fond commande '1
Private Const BC_F_JOURS As Long = 14737632 'fond jours '1
Private Const BC_CMD As Long = 14737632 'fond commandes '2
Private Const FC_CMD As Long = 0 'couleur police commandes '4
Private Const F_CMD As String = "Tahoma" 'police commandes '3
Private Const BC_LAB As Long = 14737632 'fond labels '1
Private Const BC_L As Long = 8438015 'fond boutons lundi '2
Private Const BC_Ma As Long = 8438015 'fond boutons mardi '2
Private Const BC_Me As Long = 8438015 'fond boutons mercredi '2
Private Const BC_J As Long = 8438015 'fond boutons jeudi '2
Private Const BC_V As Long = 8438015 'fond boutons vendredi '2
Private Const BC_S As Long = 192 'fond boutons samedi '2
Private Const BC_D As Long = 192 'fond boutons dimanche '2
Private Const BC_F As Long = 8454016 'fond boutons fériés '2
Private Const FC_LAB As Long = 0 'couleur police labels '4
Private Const FC_Lu As Long = 0 'couleur police lundi '4
Private Const FC_Ma As Long = 8388608 'couleur police mardi '4
Private Const FC_Me As Long = 0 'couleur police mercredi '4
Private Const FC_J As Long = 789516 'couleur police jeudi '4
Private Const FC_V As Long = 789516 'couleur police vendredi '4
Private Const FC_S As Long = 14211288 'couleur police samedi '4
Private Const FC_D As Long = 14211288 'couleur police dimanche '4
Private Const FC_F As Long = 0 'couleur police fériés '4
Private Const F_LAB As String = "Cambria" 'police labels '3
Private Const F_JOURS As String = "Constantia" 'police jours '3
Private Const FORM_DATE As String = "dd/mm/yyyy" 'format date '0
Private Const LIST_FORMATS As String = "dd/mm/yy;dd/mm/yyyy;mm/dd/yyyy;dd mmmm yyyy;dddd d mmmm yyyy" 'liste formats '0
Private Const LIST_FONTS As String = "Arial;Calibri;Cambria;Comic Sans MS;Constantia;Courier New;Garamond;Georgia;Lucida Calligraphy;Lucida Console;MS Sans Serif;Monotype Corsiva;Tahoma;Times New Roman;Verdana" 'liste fonts '3
'////FIN PARAMETRES
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim cCalYtRpZaert As New Calendrier
Private Sub Class_Initialize()
Set Dico = CreateObject("Scripting.dictionary")
End Sub
Public Function Value(Optional L#, Optional T#)
Dim Liste, Sep$, Jour$, Mois$, Annee$
Call NewUsf(Format(Date, "mmmm yyyy"), 7 * (W_BTN + MARGE_L) + MARGE_L + 5, MARGE_T * 2 + H_BTN, L, T)
Liste = Liste_Parametres
Call Creer_Calendrier(Date, "", Liste)
Call Usf_Initialize
Usf.Controls("Btn_Jours" & Day(Date)).SetFocus
Usf.Show
On Error GoTo Fin
Sep = Application.International(xlDateSeparator)
Value = Format(Usf.Tag & Sep & Month(Usf.Caption) & Sep & Right(Usf.Caption, 4), FORM_DATE)
Unload Usf
Exit Function
Fin:
MsgBox "erreur"
End Function
Private Sub NewUsf(Cap$, W%, H%, Optional L#, Optional T#)
Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
Nom = Usf.Name
VBA.UserForms.Add (Nom)
Set Usf = UserForms(UserForms.Count - 1)
With Usf
.Caption = Cap
.BackColor = BC_USF
.StartUpPosition = 0
If L Then
.Move L, T
Else
.Move (Application.Width - .Width) / 2, (Application.Height - .Height) / 2
End If
End With
End Sub
Private Sub NewFrme(Name$, Caption$, Left%, Top%, Width%, Height%, BckCol&)
Dim obj As Object
Set obj = Usf.Controls.Add("forms.frame.1")
If TypeName(obj) = "Nothing" Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.FRM = obj
With cCalYtRpZaert.FRM
.Name = Name
.Caption = Caption
.BackColor = BckCol
.Move Left, Top, Width, Height
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewBouton(Name$, Caption$, Width%, Height%, Left%, Top%, BckC&, ForeC&, fontSize%, Page%)
Dim obj As Object
If Page > -1 Then
Set obj = MultiPage(Page).Controls.Add("forms.CommandButton.1")
Else
Set obj = FRM.Controls.Add("forms.CommandButton.1")
End If
If obj = True Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.Bouton = obj
Set cCalYtRpZaert.FRM = FRM
With cCalYtRpZaert.Bouton
.Name = Name
.Caption = Caption
.Move Left, Top, Width, Height
.BackColor = BckC
.ForeColor = ForeC
.Font.Size = fontSize
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewLabel(Name$, Caption$, Left%, Top%, Width%, Height%, BckC&, ForeC&, fontSize%, Page%)
Dim obj As Object
If Page > -1 Then
Set obj = MultiPage(Page).Controls.Add("forms.Label.1")
Else
Set obj = FRM.Controls.Add("forms.Label.1")
End If
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.Labl = obj
With cCalYtRpZaert.Labl
.Name = Name
.Caption = Caption
.Move Left, Top, Width, Height
.Object.BackColor = BckC
.Object.ForeColor = ForeC
.TextAlign = fmTextAlignCenter
.Font.Size = fontSize
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewMultiPage(Name$, Left%, Top%, Width%, Height%, Nb%, ParamArray Onglets())
Dim obj As Object, n%, i%
Set obj = Usf.Controls.Add("forms.MultiPage.1")
If TypeName(obj) = "Nothing" Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.MultiPage = obj
n = cCalYtRpZaert.MultiPage.Pages.Count
n = Nb - n
For i = 1 To n
cCalYtRpZaert.MultiPage.Pages.Add
Next
For i = 0 To UBound(Onglets)
cCalYtRpZaert.MultiPage.Pages(i).Caption = CStr(Onglets(i))
Next
With cCalYtRpZaert.MultiPage
.Name = Name
.Move Left, Top, Width, Height
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewOptBout(Name$, Caption$, Left%, Top%, Width%, Height%, cTag$, Optional Page%)
Dim obj As Object
Set obj = MultiPage(Page).Controls.Add("forms.OptionButton.1")
If obj = True Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.OpB = obj
With cCalYtRpZaert.OpB
.Name = Name
.Caption = Caption
.Tag = cTag
.Move Left, Top, Width, Height
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewTextB(Name$, Vis As Boolean, Trans%, Page%, L%, T%, W%, H%, Bloquee As Boolean, Ena As Boolean)
Dim obj As Object
If Page > -1 Then
Set obj = MultiPage(Page).Controls.Add("forms.TextBox.1")
Else
Set obj = FRM.Controls.Add("forms.TextBox.1")
End If
If obj = True Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.Txt = obj
With cCalYtRpZaert.Txt
.Name = Name
.Visible = Vis
.BackStyle = Trans
.Move L, T, W, H
.Locked = Bloquee
.Enabled = Ena
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Public Sub NewCombo(Name$, Liste, Left%, Top%, Width%, Height%, Page%)
Dim obj As Object
Set obj = MultiPage(Page).Controls.Add("forms.ComboBox.1")
If obj = True Then Exit Sub
Set cCalYtRpZaert.Usf = Usf
Set cCalYtRpZaert.Combo = obj
With cCalYtRpZaert.Combo
.Name = Name
.List = Liste
.Move Left, Top, Width, Height
End With
Dico.Add Name, cCalYtRpZaert
Set cCalYtRpZaert = Nothing
End Sub
Private Sub Usf_Initialize()
Dim hSysMenu&, MeHwnd&
MeHwnd = FindWindowA(vbNullString, Usf.Caption)
If MeHwnd > 0 Then
hSysMenu = GetSystemMenu(MeHwnd, False)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
Else
MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
End If
End Sub
Private Sub Creer_Calendrier(dte As Date, Simul$, Liste)
Dim i%, W%, H%, Haut%, Cap$, Maxi%, Ctrl As Control
W = 7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R
H = CInt(Liste(0, 3)) + BORD_R + CInt(Liste(5, 3)) * 2
NewFrme "Commandes" & Simul, "", 0, 0, W, H, CLng(Liste(10, 3))
For i = 1 To 5
Cap = CStr(Split(CAPTIONS_BTN_CMD, ",")(i - 1))
Dico("Commandes" & Simul).NewBouton "Btn_Cmd" & i, Cap, CInt(Liste(2, 3)), CInt(Liste(0, 3)), (W / 5) * (i - 1) + CInt(Liste(4, 3)), CInt(Liste(5, 3)), CLng(Liste(12, 3)), CInt(Liste(13, 3)), CInt(Liste(8, 3)), -1
Next
Call Creer_Jours(Date, Haut, Simul, Liste)
With Usf '-------------------------------------------------------- A REVOIR TAILLES USERFORM EN MODE "SIMUL"
If Simul = "" Then
.Controls("Jours").Height = Haut + H_BTN + BORD_B
.Width = W + BORD_R
.Height = H + Haut + H_BTN + BORD_B + BORD_B
Else
For Each Ctrl In .Controls
If TypeOf Ctrl Is MSForms.OptionButton Then
If Ctrl.Top > Maxi Then Maxi = Ctrl.Top
End If
Next
.Controls("Jours" & Simul).Height = Haut + CInt(Liste(0, 3)) + BORD_B
.Controls("Jours" & Simul).Width = W
.Width = W + BORD_R + 320
If .Controls("Jours" & Simul).Height > Maxi Then Maxi = .Controls("Jours" & Simul).Height + .Controls("Jours" & Simul).Top
.Height = Maxi + 30
End If
End With
End Sub
Private Sub Creer_Jours(dte As Date, Haut%, Simul$, Liste)
Dim i%, NbJ As Byte, d As Date, G%, BckC&, ForeC&, Cap$
NewFrme "Jours" & Simul, "", 0, CInt((CInt(Liste(0, 3)) + BORD_R + CInt(Liste(5, 3)) * 2) - BORD_FRAME), CInt(7 * (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) + CInt(Liste(4, 3)) + BORD_R), CInt(Liste(0, 3)), CLng(Liste(11, 3))
For i = 1 To 7
Cap = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1))
Dico("Jours" & Simul).NewLabel "Lab" & i, Cap, CInt(CInt(Liste(4, 3)) + (CInt(Liste(1, 3)) + CInt(Liste(4, 3))) * (i - 1)), CInt(Liste(5, 3)), CInt(Liste(1, 3)), CInt(Liste(3, 3)), CLng(Liste(15, 3)), CLng(Liste(24, 3)), CInt(Liste(6, 3)), -1
Next i
NbJ = Day(DateSerial(Year(dte), Month(dte) + 1, 1) - 1)
Haut = CInt(Liste(5, 3)) + CInt(Liste(3, 3)) + CInt(Liste(5, 3))
For d = DateSerial(Year(dte), Month(dte), 1) To DateSerial(Year(dte), Month(dte), NbJ)
Select Case Weekday(d, vbMonday)
Case 1: G = CInt(Liste(4, 3)): BckC = CLng(Liste(16, 3)): ForeC = CLng(Liste(25, 3)): If Day(d) <> 1 Then Haut = Haut + CLng(Liste(0, 3)) + CLng(Liste(5, 3))
Case 2: G = CInt(Liste(4, 3)) * 2 + CInt(Liste(1, 3)): BckC = CLng(Liste(17, 3)): ForeC = CLng(Liste(26, 3))
Case 3: G = CInt(Liste(4, 3)) + CInt((Liste(4, 3)) + CInt(Liste(1, 3))) * 2: BckC = CLng(Liste(18, 3)): ForeC = CLng(Liste(27, 3))
Case 4: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 3: BckC = CLng(Liste(19, 3)): ForeC = CLng(Liste(28, 3))
Case 5: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 4: BckC = CLng(Liste(20, 3)): ForeC = CLng(Liste(29, 3))
Case 6: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 5: BckC = CLng(Liste(21, 3)): ForeC = CLng(Liste(30, 3))
Case 7: G = CInt(Liste(4, 3)) + (CInt(Liste(4, 3)) + CInt(Liste(1, 3))) * 6: BckC = CLng(Liste(22, 3)): ForeC = CLng(Liste(31, 3))
End Select
If EstJourFerie(Year(d), d) Or Paques(Year(d)) = d Then BckC = CLng(Liste(23, 3)): ForeC = CLng(Liste(32, 3))
Dico("Jours" & Simul).NewBouton "Btn_Jours" & Day(d), CStr(Day(d)), CInt(Liste(1, 3)), CInt(Liste(0, 3)), G, Haut, BckC, ForeC, CInt(Liste(7, 3)), -1
Next d
End Sub
Private Sub Creer_Parametres(dte As Date, Optional Page$)
Dim ListParam, i%, Cible$, cNom$, cCap$, cPage%, cVal$, X(4), Maxi%, ListF
ListParam = Liste_Parametres
Call Creer_Calendrier(dte, "S", ListParam)
Dico("JoursS").NewTextB "Cadre", False, 0, -1, 1, 1, 1, 1, False, True
NewMultiPage "Params", Usf.Controls("JoursS").Width, 0, 320, Usf.Height, 5, "General", "Couleur conteneurs", "Couleur Boutons", "Font Style", "Font Color"
For i = 0 To 34
Dico("Params").NewOptBout CStr(ListParam(i, 0)), CStr(ListParam(i, 1)), 0, MARGE_T + 10 + X(CInt(ListParam(i, 2))), 160, 15, Replace(CStr(ListParam(i, 3)), """", ""), CInt(ListParam(i, 2))
X(ListParam(i, 2)) = X(ListParam(i, 2)) + 15
Next
Dico("Params").NewLabel "LFormDate", "Format :", 0, X(0) + 15, 100, 14, BC_USF, FC_LAB, 10, 0
Dico("Params").NewLabel "LFormFonts", "Polices :", 0, X(3) + 15, 100, 14, BC_USF, FC_LAB, 10, 3
ListF = Split(LIST_FORMATS, ";")
Dico("Params").NewCombo "ComboFormat", ListF, 0, X(0) + 30, 100, 20, 0
ListF = Split(LIST_FONTS, ";")
Call tri(ListF, LBound(ListF), UBound(ListF))
Dico("Params").NewCombo "ComboFonts", ListF, 0, X(3) + 30, 100, 20, 3
For i = 0 To 3
If X(i) > X(i + 1) Then Maxi = X(i) Else Maxi = X(i + 1)
Next i
For i = 0 To 4
Dico("Params").NewBouton "Croix" & i, "X", 20, 20, 290, 0, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
If i <> 1 And i <> 2 And i <> 4 Then
Dico("Params").NewBouton "VALID" & i, "Valider", 60, 20, 185, 45, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
Else
Dico("Params").NewBouton "VALID" & i, "OK", 20, 20, 250, 20, BC_CMD, FC_CMD, FONT_SIZE_BTN_CMD, i
End If
Dico("Params").NewLabel "Lancien" & i, "Ancien :", 120, 5, 60, 14, BC_USF, FC_LAB, 10, i
Dico("Params").NewTextB "Ancien" & i, True, 1, i, 120, 20, 60, 20, True, False
Dico("Params").NewLabel "Lnouveau" & i, "Nouveau :", 185, 5, 60, 14, BC_USF, FC_LAB, 10, i
Dico("Params").NewTextB "Nouveau" & i, True, 1, i, 185, 20, 60, 20, False, True
Dico("Params").NewLabel "LCache" & i, "", 0, 0, 0, 0, BC_USF, FC_LAB, 10, i
If i = 1 Or i = 2 Or i = 4 Then Call CreerBoutonsCouleurs(i)
Next i
With Usf
.Controls("Params").Height = Maxi + 60
If .Height < .Controls("Params").Height Then
.Height = .Controls("Params").Height
End If
End With
If Page <> "" Then Usf.Controls("Params").Value = CInt(Page)
End Sub
Private Sub CreerBoutonsCouleurs(P%)
Dim i%, Coul, List$, X%, Y%, Cpt%
List = "16777215;12632319;12640511;12648447;12648384;16777152;16761024;16761087;14737632;8421631;8438015;8454143;8454016;16777088;16744576;16744703;12632256;255;33023;65535;65280;16776960;16711680;16711935;8421504;192;16576;49344;49152;12632064;12582912;12583104;4210752;128;16512;32896;32768;8421376;8388608;8388736;0;64;4210816;16448;16384;4210688;4194304;4194368"
Coul = Split(List, ";")
X = 120
Y = 30
For i = 0 To UBound(Coul)
If i Mod 8 = 0 Then X = 120: Y = Y + 15: Cpt = 0
Dico("Params").NewBouton "Btn_Coul" & P & i, "", 15, 15, X + (15 * Cpt), Y, CLng(Coul(i)), 0, 10, P
Cpt = Cpt + 1
Next
End Sub
Private Sub Bouton_Click()
Dim maDate As Date, P%, Anc$, Nouv$, Liste, Quoi$, Ctrl As Control
Select Case True
Case Usf.Caption = "Paramètres"
P = Usf.Controls("Params").SelectedItem.Index
For Each Ctrl In Usf.Controls("Params")(P).Controls
If TypeOf Ctrl Is MSForms.OptionButton Then
If Ctrl.Value = True Then
Quoi = Ctrl.Name
End If
End If
Next Ctrl
Select Case Bouton.Caption
Case "X"
SupprTousControles "Parametres"
Usf.Caption = Format(Date, "mmmm yyyy")
Liste = Liste_Parametres
Creer_Calendrier Date, "", Liste
Case "Valider", "OK"
If Quoi = "" Then
If P = 0 And Usf.Controls("ComboFormat") <> "" Then
Quoi = "FORM_DATE"
Else
GoTo Fin
End If
End If
Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value
Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value
If Nouv = "" Then Exit Sub
Nouv = Replace(Nouv, """", "")
Call Verif_Valeur(Nouv, Quoi, Anc)
SupprTousControles "Parametres"
Usf.Caption = "Paramètres"
Creer_Parametres Date, CStr(P)
Case ""
If Quoi = "" Then GoTo Fin
If Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = "" Then Exit Sub
Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Bouton.BackColor
Anc = Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value
Nouv = Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value
Call Simulation(P, Quoi)
Call ModifieConst(P, Quoi, Anc, Nouv)
SupprTousControles "Parametres"
Usf.Caption = "Paramètres"
Creer_Parametres Date, CStr(P)
End Select
Case Else
Select Case Bouton.Caption
Case "<<": ChangeCaptionUsf 0, -1
Case "<": ChangeCaptionUsf -1, 0
Case ">": ChangeCaptionUsf 1, 0
Case ">>": ChangeCaptionUsf 0, 1
Case "P"
maDate = CDate("1 " & Usf.Caption)
SupprTousControles "Calendrier"
Usf.Caption = "Paramètres"
Creer_Parametres maDate
Case Else
Usf.Tag = Right("0" & Bouton.Caption, 2)
Usf.Hide
End Select
End Select
Exit Sub
Fin:
MsgBox "Vous devez préalablement sélectionner un paramètre à modifier", vbInformation
End Sub
Private Sub Bouton_MouseMove(ByVal Button%, ByVal Shift%, ByVal X As Single, ByVal Y As Single)
Dim maDate As Date
If Usf.Caption = "Paramètres" Then
If Bouton.Caption = "X" Then Bouton.ControlTipText = "Fermeture"
If Bouton.Caption = "OK" Then Bouton.ControlTipText = "Validation des saisies manuelles"
If Bouton.Caption = "Valider" Then Bouton.ControlTipText = "Validation"
Exit Sub
End If
If FRM.Name <> "Jours" Then Exit Sub
If Bouton.Caption = "<<" Or Bouton.Caption = "<" Or Bouton.Caption = ">" Or Bouton.Caption = ">>" Or Bouton.Caption = "P" Or Bouton.Caption = "" Then Exit Sub
maDate = CDate(Bouton.Caption & "/" & Usf.Caption)
If EstJourFerie(Year(maDate), maDate) Or Paques(Year(maDate)) = maDate Then Bouton.ControlTipText = QuelFerie(maDate)
End Sub
Private Sub OpB_Click()
Dim Diff%, ListParam
ListParam = Liste_Parametres
If OpB = True Then
Diff = CInt(ListParam(5, 3)) * 2 + CInt(ListParam(3, 3))
Select Case OpB.Caption
'MoveCadre(Width%, Height%, Left%, Top%, Vis As Boolean)
Case "fond labels", "couleur police labels": MoveCadre Usf.Controls("JoursS").Width, CInt(ListParam(3, 3)), 0, 0, True
Case "fond boutons lundi", "couleur police lundi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, 0, Diff, True
Case "fond boutons mardi", "couleur police mardi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Diff, True
Case "fond boutons mercredi", "couleur police mercredi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (ListParam(1, 3) + CInt(ListParam(4, 3))) * 2, Diff, True
Case "fond boutons jeudi", "couleur police jeudi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 3, Diff, True
Case "fond boutons vendredi", "couleur police vendredi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 4, Diff, True
Case "fond boutons samedi", "couleur police samedi": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 5, Diff, True
Case "fond boutons dimanche", "couleur police dimanche": MoveCadre CInt(ListParam(1, 3)) + CInt(ListParam(4, 3)), Usf.Controls("JoursS").Height - Diff - 10, (CInt(ListParam(1, 3)) + CInt(ListParam(4, 3))) * 6, Diff, True
Case Else: MoveCadre 0, 0, 0, 0, False
End Select
Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = OpB.Tag
End If
End Sub
Private Sub Combo_Click()
Dim i%, Cible$, Fin$, Liste, Ctrl As Control
If Combo.Value = "" Then Exit Sub
Liste = Liste_Parametres
Select Case Combo.Name
Case "ComboFormat"
For Each Ctrl In Usf.Controls("Params")(Usf.Controls("Params").SelectedItem.Index).Controls
If TypeOf Ctrl Is MSForms.OptionButton Then
If Ctrl.Value = True Then Ctrl.Value = False
End If
Next Ctrl
Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = Replace(Liste(35, 3), """", "")
Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Combo.Value
Case "ComboFonts"
If Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value = "" Then
MsgBox "Vous devez préalablement choisir une option à modifier", vbInformation
Exit Sub
End If
If IsNumeric(Usf.Controls("Ancien" & Usf.Controls("Params").SelectedItem.Index).Value) Then
MsgBox "Ce type de paramètre n'admet pas cette valeur. " & vbCrLf & _
"Merci de saisir une valeur numérique dans le champ de saisie NOUVEAU.", vbInformation
Combo.Value = ""
Exit Sub
End If
Usf.Controls("Nouveau" & Usf.Controls("Params").SelectedItem.Index).Value = Combo.Value
Combo.Value = ""
End Select
Exit Sub
Fin:
MsgBox "La constante de format de date FORM_DATE a été effacée!", vbCritical
End Sub
Private Sub MultiPage_Change()
MoveCadre 0, 0, 0, 0, False
End Sub
Private Sub Class_Terminate()
Dim i%, VBComp As VBComponent
Set Dico = Nothing
If Nom <> "" Then
Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub
Private Sub ChangeCaptionUsf(m%, Y%)
Dim Cap$, maDate As Date, Haut%, Liste
Cap = Usf.Caption
maDate = CDate(1 & " " & Cap)
maDate = DateSerial(Year(maDate) + Y, Month(maDate) + m, 1)
Usf.Caption = Format(maDate, "mmmm yyyy")
Call RemoveBoutonsJours
Liste = Liste_Parametres
Call Creer_Jours(maDate, Haut, "", Liste)
Usf.Controls("Jours").Height = Haut + H_BTN + BORD_B
Usf.Height = Usf.Controls("Jours").Height + Usf.Controls("Jours").Top + BORD_B
End Sub
Private Sub RemoveBoutonsJours()
Usf.Controls.Remove "Jours"
Set Dico("Jours") = Nothing
Dico.Remove "Jours"
End Sub
Private Sub SupprTousControles(Duquel$)
Select Case Duquel
Case "Parametres"
Usf.Controls.Remove "JoursS"
Set Dico("JoursS") = Nothing
Dico.Remove "JoursS"
Usf.Controls.Remove "CommandesS"
Set Dico("CommandesS") = Nothing
Dico.Remove "CommandesS"
Usf.Controls.Remove "Params"
Set Dico("Params") = Nothing
Dico.Remove "Params"
Case "Calendrier"
Usf.Controls.Remove "Jours"
Set Dico("Jours") = Nothing
Dico.Remove "Jours"
Usf.Controls.Remove "Commandes"
Set Dico("Commandes") = Nothing
Dico.Remove "Commandes"
Case "Simulation"
Usf.Controls.Remove "JoursS"
Set Dico("JoursS") = Nothing
Dico.Remove "JoursS"
Usf.Controls.Remove "CommandesS"
Set Dico("CommandesS") = Nothing
Dico.Remove "CommandesS"
End Select
End Sub
Private Sub MoveCadre(Width%, Height%, Left%, Top%, Vis As Boolean)
Usf.Controls("Cadre").Move Left, Top, Width, Height
Usf.Controls("Cadre").Visible = Vis
End Sub
Private Function Liste_Parametres() As Variant()
Dim i%, Cible$, Cpt%, ListParam(37, 3)
'Source : http://excel.developpez.com/faq/index.php?page=VBA#RemplacerMotVBE
With ActiveWorkbook.VBProject.VBComponents("Calendrier").CodeModule
Do
i = i + 1
Cible = .Lines(i, 1)
Loop While Cible <> "'////DEBUT PARAMETRES"
i = i + 1
Do
Cible = .Lines(i, 1)
If Cible = "'////FIN PARAMETRES" Then Exit Do
ListParam(Cpt, 0) = Mid(Cible, InStr(Cible, "Const") + 6, InStr(Cible, "As") - (InStr(Cible, "Const") + 7)) 'nom de la constante
ListParam(Cpt, 1) = Trim(Split(Cible, "'")(1)) 'Caption OpB
ListParam(Cpt, 2) = CInt(Split(Cible, "'")(2)) 'Page du multipage
ListParam(Cpt, 3) = Trim(Split(Split(Cible, "'")(0), "=")(1)) 'valeur de la constante
Cpt = Cpt + 1
i = i + 1
Loop
End With
Liste_Parametres = ListParam
End Function
Private Sub Simulation(P%, Quoi$)
Dim i%, ListParam, maVal
ListParam = Liste_Parametres
maVal = Usf.Controls("Nouveau" & P).Value
For i = 0 To 37
If CStr(Quoi) = CStr(ListParam(i, 0)) Then
ListParam(i, 3) = maVal
Exit For
End If
Next i
End Sub
Private Sub ModifieConst(P%, Quoi$, Ancien$, Nouveau$)
Dim i%, Cible$
With ActiveWorkbook.VBProject.VBComponents("Calendrier").CodeModule
Do
i = i + 1
Cible = .Lines(i, 1)
Loop While Cible <> "'////DEBUT PARAMETRES"
i = i + 1
Do
Cible = .Lines(i, 1)
If Cible = "'////FIN PARAMETRES" Then Exit Do
If Cible Like "Private Const " & Quoi & "*" Then
Cible = Replace(Cible, Ancien, Nouveau)
.ReplaceLine i, Cible
End If
i = i + 1
Loop
End With
End Sub
Private Sub Verif_Valeur(maVal$, Quoi$, Anc$)
Dim ListParam, ListF, i%, Trouve As Boolean, Nouv$, Modif As Boolean
Select Case Quoi
Case "": Exit Sub
Case "H_BTN", "W_BTN", "W_CMD", "H_LAB" '-taille des boutons et labels
If test_1(maVal, Anc) Then test_2 maVal, Anc, 10, 60
Case "MARGE_L", "MARGE_T" '-marges
If test_1(maVal, Anc) Then test_2 maVal, Anc, 0, 10
Case "FONT_SIZE_LAB", "FONT_SIZE_BTN", "FONT_SIZE_BTN_CMD" '-taille police
If test_1(maVal, Anc) Then test_2 maVal, Anc, 6, 20
Case "F_LAB", "F_JOURS", "F_CMD" '-polices
If Police_Exist(maVal) Then
ListParam = Liste_Parametres
ListF = Split(LIST_FONTS, ";")
Trouve = False
For i = 0 To UBound(ListF)
If CStr(ListF(i)) = maVal Then Trouve = True: Exit For
Next i
If Trouve = False Then
ReDim Preserve ListF(UBound(ListF) + 1)
ListF(UBound(ListF)) = maVal
Call tri(ListF, LBound(ListF), UBound(ListF))
Nouv = Join(ListF, ";")
ModifieConst Usf.Controls("Params").SelectedItem.Index, "LIST_FONTS", CStr(ListParam(37, 3)), """" & Nouv & """"
ModifieConst Usf.Controls("Params").SelectedItem.Index, Quoi, Anc, maVal
Modif = True
End If
Else
MsgBox "Police inconnue dans votre système d'exploitation", vbInformation
maVal = Anc
Modif = True
End If
Case "FORM_DATE"
ListF = Split(LIST_FORMATS, ";")
Modif = True
For i = 0 To UBound(ListF)
If CStr(ListF(i)) = maVal Then
MsgBox "Cette modification ne sera prise en compte qu'à partir de la prochaine utilisation", vbInformation
Modif = False
Exit For
End If
Next i
Case Else '-couleurs back et forecolor
If test_1(maVal, Anc) Then test_2 maVal, Anc, 0, 2147483647
End Select
If Modif = False Then
Call Simulation(Usf.Controls("Params").SelectedItem.Index, Quoi)
Call ModifieConst(Usf.Controls("Params").SelectedItem.Index, Quoi, Anc, maVal)
End If
End Sub
Private Function test_1(maVal$, Anc$) As Boolean
If Not IsNumeric(maVal) Then
MsgBox "Cette valeur doit être numérique"
maVal = Anc
Exit Function
End If
test_1 = True
End Function
Private Sub test_2(maVal$, Anc$, BorneInf&, BorneSup&)
If Val(maVal) < BorneInf Or Val(maVal) > BorneSup Then
MsgBox "Cette valeur doit être comprise entre " & BorneInf & " et " & BorneSup
maVal = Anc
End If
End Sub
Private Function Police_Exist(myNom$) As Boolean
On Error Resume Next
With New StdFont
.Name = myNom
Police_Exist = (StrComp(myNom, .Name, vbTextCompare) = 0)
myNom = .Name
End With
End Function
Private Function EstJourFerie(ByVal Annee%, ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean
'Philben - v1.0 - 2012 - Free to use
Static dPa As Date, dAs As Date, dPe As Date, bPe As Boolean
Dim a%, m%, j%
a = Year(laDate): m = Month(laDate): j = Day(laDate)
Select Case m * 100 + j
Case 101, 501, 508, 714, 815, 1101, 1111, 1225
EstJourFerie = True
Case 323 To 614 '323: Date mini Lundi de Pâques - 614 : Date maxi Lundi de Pentecôte
If a <> Annee Or EstPentecoteFerie <> bPe Then
Annee = a: dPa = Paques(a) + 1: dAs = dPa + 38
bPe = EstPentecoteFerie: If bPe Then dPe = dPa + 49 Else dPe = #1/1/100#
End If
Select Case DateSerial(a, m, j): Case dPa, dAs, dPe: EstJourFerie = True: End Select
End Select
End Function
Private Function Paques(ByVal An%) As Date
'Philben - v1.0 - Free to use
Dim a%, b%, c%, d%, e%, F%
If An < 10000 Then 'Limite supérieure des dates sous Access (31 décembre 9999)
Select Case An
Case 1900 To 2099 'Algorithme de Carter
a = (204 - 11 * (An Mod 19)) Mod 30 + 22
Paques = DateSerial(An, 3, a + 6 + (a > 49) - (An + An \ 4 + a + (a > 49)) Mod 7)
Case Is > 1582 'Proposé en 1876 dans la revue Nature (dérivé de l'algorithme de Delambre)
a = An Mod 19: b = An \ 100: c = An Mod 100
d = (19 * a + b - b \ 4 - (b - (b + 8) \ 25 + 1) \ 3 + 15) Mod 30
e = (32 + 2 * (b Mod 4) + 2 * (c \ 4) - d - c Mod 4) Mod 7
F = d + e - 7 * ((a + 11 * d + 22 * e) \ 451) + 114
Paques = DateSerial(An, F \ 31, F Mod 31 + 1)
Case Is > 324 'Algorithme de Oudin pour les dates juliennes < 1583 décrit par Claus Tondering
a = (19 * (An Mod 19) + 15) Mod 30
Paques = DateSerial(An, 3, 28 + a - (An + An \ 4 + a) Mod 7)
End Select
End If
End Function
Private Function QuelFerie(Jour As Date) As String
Dim maDate As Date, a%, m%, j%
maDate = Paques(Year(Jour))
Select Case Jour
Case maDate: QuelFerie = "Dimanche de Pâques": Exit Function
Case CDate(maDate + 1): QuelFerie = "Lundi de Pâques": Exit Function
Case CDate(maDate + 50): QuelFerie = "Lundi de Pentecôte": Exit Function
Case CDate(maDate + 39): QuelFerie = "Jeudi de l'ascension": Exit Function
End Select
a = Year(Jour): m = Month(Jour): j = Day(Jour)
Select Case m * 100 + j
Case 101: QuelFerie = "Nouvel An": Exit Function
Case 501: QuelFerie = "Fête du travail": Exit Function
Case 508: QuelFerie = "Armistice 39-45": Exit Function
Case 714: QuelFerie = "Fête Nationale": Exit Function
Case 815: QuelFerie = "Assomption": Exit Function
Case 1101: QuelFerie = "Toussaint": Exit Function
Case 1111: QuelFerie = "Armistice 14-18": Exit Function
Case 1225: QuelFerie = "Noël": Exit Function
End Select
End Function
Sub tri(a, gauc, droi) ' Quick sort
'http://boisgontierjacques.free.fr/
Dim ref, G, d, Temp
ref = a((gauc + droi) \ 2)
G = gauc: d = droi
Do
Do While a(G) < ref: G = G + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If G <= d Then
Temp = a(G): a(G) = a(d): a(d) = Temp
G = G + 1: d = d - 1
End If
Loop While G <= d
If G < droi Then Call tri(a, G, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
Dites moi....
Bonjour,
Fonctionne très bien sous Excel 2013.
Par contre pourquoi inhiber le query_close ?
Concernant le code je regarderai à tête reposée parce que pour le coup il y a eu du boulot de fait.
En tout cas bravo
Il y a quelques petits bugs qui sont en cours de correction.
Pourquoi inhiber le QueryClose?
2 raisons :
- le calendrier doit retourner une valeur
- de mémoire, ça plante pitoyablement si on ferme l'userform par la croix (genre une erreur "l'objet invoqué s'est déconnecté" ou quelque chose d'avoisinant...)
Bonjour,
Je voulais juste vous témoigner mon soutien
Je me suis attaché à amélioré un fichier de réservation de salle que j'avais partagé sur le forum afin de me dispenser du module monthview pas accessible à tous.
J'avais pas pensé à ce fil que j'avais pourtant déjà visé...
Moi je suis passé par un userform et un module de classe que j'ai adapté.
pijaku a écrit :Elle se composera d'un seul Module de Classe. Fini le module Userform + le module de classe.
Je suis intrigué de voir comment tu fais çà ?
A bientôt
Cordialement,
Leakim
Bonjour,
Je suis intrigué de voir comment tu fais çà ?
En créant une classe, tu créées un objet.
Il suffit donc de dire que :
- ta première instance de classe est un Userform
- les autres sont des contrôles.
Tout simplement en les plaçant dans des Dictionary (plus souples que les collection).
Le premier sera le Dico de l'userform.
Et tu les "imbriques"...
A la sortie tu obtiens un Userform et tous ses contrôles...
Cf l'exemple ci dessus.
Voilà
Bonjour,
Voici donc la version finale que j'espère sans bugs...
@Fred35 : j'y ai ajouté un paramètre optional : inhib. Réglé à True ou False il inhibe ou pas la croix de fermeture de l'userform
N'hésitez pas à me faire remonter toutes vos remarques et/ou demande d'ajout et/ou de complément d'infos...
ps : le code est commenté.
Merci Pijaku, je n'avais déjà pas trouvé de bugs dans la version précédente.
J'essaierai dans les prochains jours.
Beau travail en tout cas.