Userform comme calendrier

Résolu
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -  
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour à tous,

J'ai trouvé un tutoriel avec un fichier exemple pour avoir un calendrier qui apparaît plutot que de rentrer une date dans une InputBox.

Mais il y a quelque chose qui m'échappe.

En quoi : 
Private Sub CommandButton1_Click()
Calendrier.Show
End Sub


Est différent de 

Sub Calendrier()
Calendrier.Show
End Sub


Si je met sur un bouton? J'ai "Fonction ou variable attendue".

Je vous met tout le code si ca vous intéresse :

Sur le userform : 

Option Explicit

Private Sub UserForm_Initialize()
Dim Obj As Control
Dim i As Integer, Mois As Integer, Annee As Integer
Dim Cl As ClasseBtnChange

'Création Boutons Changement de mois et d'année
Set Collect = New Collection

'BOUTONS :
    '- < et > = mois
    '- >> et << = année
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "AnneePrec"
    .Object.Caption = "<<"
    .Left = 27
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "MoisPrec"
    .Object.Caption = "<"
    .Left = 50
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "MoisSuiv"
    .Object.Caption = ">"
    .Left = 75
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl
Set Obj = Me.Controls.Add("forms.CommandButton.1")
With Obj
    .Name = "AnneeSuiv"
    .Object.Caption = ">>"
    .Left = 98
    .Top = 1
    .Width = 20
    .Height = 20
End With
Set Cl = New ClasseBtnChange
Set Cl.Bouton = Obj
Collect.Add Cl

'Création entête Jours de la semaine
For i = 1 To 7
    Set Obj = Me.Controls.Add("forms.Label.1")
    With Obj
        .Name = "Jour" & i
        .Object.Caption = UCase(Left(Format(DateSerial(2014, 9, i), "dddd"), 1))
        .Left = 20 * (i - 1) + 5
        .Top = 25
        .Width = 20
        .Height = 10
    End With
Next i

'création boutons "jours"
Mois = Month(Date)
MoisEnCours = Mois
Annee = Year(Date)
AnneeEnCours = Annee
CreationBoutonsJours Mois, Annee
If Left(Format(Date, "dd"), 1) = "0" Then Me.Controls("Bouton" & Format(Date, "d")).SetFocus Else Me.Controls("Bouton" & Format(Date, "dd")).SetFocus

Set Cl = Nothing
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Set CollecBtnJours = Nothing
Set Collect = Nothing
End Sub


Sur un module nommé "Fonctions" : 

Option Explicit

Public Collect As Collection, CollecBtnJours As Collection
Public MoisEnCours As Integer, AnneeEnCours As Integer

'Procédure de création des boutons Jours
'en fonction de l'année et du mois "en cours"
Sub CreationBoutonsJours(Mois As Integer, Annee As Integer)
Dim Obj As Control
Dim Cls As ClasseBtnJours
Dim NbJours As Integer, T As Integer, Gauc As Integer, Coul As Long, i As Integer, Taille As Integer

'Suppression de tous les boutons de commande "Jours"
For Each Obj In calendrier.Controls
    If Left(Obj.Name, 6) = "Bouton" Then calendrier.Controls.Remove Obj.Name
Next

'création des boutons jours en fonction de l'année et du mois "en cours"
Set CollecBtnJours = New Collection
NbJours = Day(DateSerial(Annee, Mois + 1, 1) - 1)
For i = 1 To NbJours
    If i = 1 Then T = 35
    Select Case UCase(Format(DateSerial(Annee, Mois, i), "dddd"))
        Case "LUNDI"
            Gauc = 0
            If i <> 1 Then T = T + 20
            Coul = 13037551
        Case "MARDI"
            Gauc = 20
            Coul = 13037551
        Case "MERCREDI"
            Gauc = 40
            Coul = 13037551
        Case "JEUDI"
            Gauc = 60
            Coul = 13037551
        Case "VENDREDI"
            Gauc = 80
            Coul = 13037551
        Case "SAMEDI"
            Gauc = 100
            Coul = 3754751
        Case "DIMANCHE"
            Gauc = 120
            Coul = 3754751
    End Select
    If EstJourFerie(DateSerial(Annee, Mois, i)) Or Paques(Annee) = DateSerial(Annee, Mois, i) Then Coul = 1627780
    Set Obj = calendrier.Controls.Add("forms.CommandButton.1")
    With Obj
        .Name = "Bouton" & i
        .Object.Caption = i
        .Left = Gauc
        .Top = T
        .Width = 20
        .Height = 20
        .Object.BackColor = Coul
    End With
    If i = NbJours Then Taille = Obj.Top + Obj.Height + 20
    Set Cls = New ClasseBtnJours
    Set Cls.Btn = Obj
    CollecBtnJours.Add Cls
Next i
With calendrier
    .Caption = Format(DateSerial(AnneeEnCours, MoisEnCours, 1), "mmmm yyyy")
    .Tag = MoisEnCours & "/" & AnneeEnCours
    .Height = Taille
    .Width = 145
End With
Set Cls = Nothing
End Sub

'Fonction qui retourne le jour férié en "String"
'utile pour les info-bulles au survol des jours fériés
Public Function QuelFerie(Jour As Date) As String
Dim maDate As Date
Dim a As Integer, m As Integer, j As Integer

maDate = Paques(Year(Jour))
If Jour = maDate Then QuelFerie = "Dimanche de Pâques": Exit Function
If Jour = CDate(maDate + 1) Then QuelFerie = "Lundi de Pâques": Exit Function
If Jour = CDate(maDate + 50) Then QuelFerie = "Lundi de Pentecôte": Exit Function
If Jour = CDate(maDate + 39) Then QuelFerie = "Jeudi de l'ascension": Exit Function

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 (2ème guerre mondiale)": 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 (1ère guerre mondiale)": Exit Function
  Case 1225
    QuelFerie = "Noël": Exit Function
End Select
End Function

'SOURCES :
    'http://blog.developpez.com/philben/p11458/vba-access/sagit-il-dun-jour-ferie
Public Function EstJourFerie(ByVal laDate As Date, Optional ByVal EstPentecoteFerie As Boolean = True) As Boolean
'Détermine si la date passée en argument est un jour férié (en France) ou non :
'   101 = 1er Janvier - 501 = 1er Mai - 508 = 8 Mai - 714 = 14 Juillet
'   815 = 15 Août - 1101 = 1er Novembre - 1111 = 11 Novembre - 1225 = 25 Décembre
'   dPa = Lundi de Pâques - dAs = Jeudi de l'Ascension - dPe = Lundi de Pentecôte
'Remarque : Le lundi de Pentecôte est un jour férié mais parfois non chômé (EstPentecoteFerie = False dans ce cas)
'Philben - v1.0 - 2012 - Free to use
  Static Annee As Integer, dPa As Date, dAs As Date, dPe As Date, bPe As Boolean
   Dim a As Integer, m As Integer, j As Integer

   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

'SOURCES :
    'http://blog.developpez.com/philben/p11431/vba-access/calculer-la-date-de-paques
Public Function Paques(ByVal an As Integer) As Date
'Calcul de la date du dimanche de Pâques à partir de l'année 325
'Performance par million d'appel :
'   - Entre 325 et 1582 et entre 1900 et 2099   => 1/4 de seconde
'   - Année supérieure à 1582 hors 1900 - 2099 => 1/2 de seconde
'Philben - v1.0 - Free to use
  Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer
   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


Sur un module de classe : 

Public WithEvents Bouton As MSForms.CommandButton

'Module de classe pour les boutons : <<  <  >  >>

Private Sub Bouton_Click()
Select Case Bouton.Name
    Case "AnneePrec"
        AnneeEnCours = AnneeEnCours - 1
        If AnneeEnCours = 1899 Then
            MoisEnCours = 1
            AnneeEnCours = 1900
            MsgBox "Première année : 1900"
        End If
    Case "MoisPrec"
        MoisEnCours = MoisEnCours - 1
        If MoisEnCours = 0 Then
            MoisEnCours = 12
            AnneeEnCours = AnneeEnCours - 1
            If AnneeEnCours = 1899 Then
                MoisEnCours = 1
                AnneeEnCours = 1900
                MsgBox "Première année : 1900"
            End If
        End If
    Case "MoisSuiv"
        MoisEnCours = MoisEnCours + 1
        If MoisEnCours = 13 Then
            MoisEnCours = 1
            AnneeEnCours = AnneeEnCours + 1
        End If
    Case "AnneeSuiv"
        AnneeEnCours = AnneeEnCours + 1
End Select
CreationBoutonsJours MoisEnCours, AnneeEnCours
End Sub


Sur un autre module de classe : 

Option Explicit

Public WithEvents Btn As MSForms.CommandButton

'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date

maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
    'Pour entrer la date choisie dans une cellule et fermer l'Userform :
        'ActiveCell.Value = maDate
        'Unload Calendrier
MsgBox maDate
End Sub

'Affiche le nom du jour férié au survol du bouton par la souris
Private Sub Btn_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim maDate As Date

maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
If EstJourFerie(maDate) Or Paques(Year(maDate)) = maDate Then Btn.ControlTipText = QuelFerie(maDate)
End Sub


Parce qu'en fait, le but était de l'intégrer à ma macro comme une InputBox. Il aurait fallut que je puisse faire choisir la date sur ce caldendrier et qu'elle soit stockée dans une variable qui servira à l'enregistrement du fichier et bien d'autres choses...

Que je puisse l'utiliser un peu comme ça en fait : 

Public DATE_ECHEANCE As String

Sub TRAITEMENT_VIREMENTS()

If Range("A1").Font.Bold = True Then
MsgBox ("La mise en forme a déjà été faite.")
Exit Sub
End If

Dim DL As Long, DL2 As Long, DL3 As Long, Obj As Object, Code As String

Do
   DATE_ECHEANCE = InputBox("Entrer la date d'échéance des factures concernées au format jj/mm/aaaa.", "Date d'échéance")
Loop While DATE_ECHEANCE = "" Or Not IsDate(DATE_ECHEANCE) Or DATE_ECHEANCE <> Format(DATE_ECHEANCE, "dd/mm/yyyy")

.
.
.



Merci de votre aide. Désolé pour le flood.
A voir également:

1 réponse

Réponse 1 / 1
f894009 Messages postés 17413 Statut Membre 1 715
 
Bonjour, 

Sub Calendrier()
Calendrier.Show
End Sub


Vous donnez le meme nom a deux objets , donc l'erreur est normale
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Merci beaucoup pour avoir mis le doigt sur cette erreur des plus stupides...

Savez-vous à quel endroit du code il est dit que si je clique sur un jour dans le calendrier une MsgBox apparaît en me donnant la date sur laquelle j'ai cliqué?

Au lieu d'une MsgBox, je voudrais bien stocker cette réponse dans une variable en fait. Que je puisse m'en resservir. Comme une InputBox quoi.

Et comment faire pour qu'une fois que j'ai choisi ma date et que la variable est stockée, le calendrier se ferme?

Merci encore.
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Ok j'ai rien dit, trouvé c'était écrit noir sur blanc....

Merci beaucoup.
0
f894009 Messages postés 17413 Statut Membre 1 715 > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
 
Re, 

Option Explicit

Public WithEvents Btn As MSForms.CommandButton

'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date

maDate = CDate(Btn.Caption & "/" & calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
    'Pour entrer la date choisie dans une cellule et fermer l'Userform :
        'ActiveCell.Value = maDate
        DATE_ECHEANCE = maDate
        Unload Calendrier
End Sub
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Dernière petite question, là j'ai un calendrier qui arrive parfait. Serait-il possible d'écrire dessus un titre du genre : "Choisissez la date d'échéance"?

Là j'ai l'impression que tous les espaces sont utilisés..
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
J'ai un petit soucis par contre, j'ai donc modifié le code en : 

Option Explicit
Public DATE_ECHEANCE As String
Public WithEvents Btn As MSForms.CommandButton

'Procédure lors du clic sur un bouton "jour"
Private Sub Btn_Click()
Dim maDate As Date

DATE_ECHEANCE = CDate(Btn.Caption & "/" & Calendrier.Tag)
'La ligne suivante détermine l'action à effectuer lors d'un clic sur le bouton
    'Pour entrer la date choisie dans une cellule et fermer l'Userform :
        'ActiveCell.Value = maDate
Unload Calendrier
End Sub


Mon code final est donc : 

Sub TRAITEMENT_FINAL()

Calendrier.Show

Call TRAITEMENT_VIREMENTS

End Sub


Qui appelle le code suivant : 

Sub TRAITEMENT_VIREMENTS()

If Range("A1").Font.Bold = True Then
MsgBox ("La mise en forme a déjà été faite.")
Exit Sub
End If

Dim DL As Long, DL2 As Long, DL3 As Long, Obj As Object, Code As String

Range("A:E,I:O,Q:Q,S:S").Delete

Rows(4).Delete

DL = Cells(Application.Rows.Count, 4).End(xlUp).Row

For i = DL To 4 Step -1

If Range("A" & i) = "" Then
    Range("A" & i).Value = CDate(Range("A" & i - 1).Value)
    Range("B" & i).Value = Range("B" & i - 1).Value
    Range("C" & i).Value = Range("C" & i - 1).Value
    Range("E" & i).Value = Range("E" & i - 1).Value
    Range("F" & i).Value = Range("F" & i - 1).Value
    Range("G" & i).Value = Range("G" & i - 1).Value
    Range("H" & i).Value = CDate(Range("H" & i - 1).Value)
Rows(i - 1).Delete

i = i - 1
ElseIf Range("B" & i) = Range("B" & i + 1) And Range("C" & i) = Range("C" & i + 1) Then
    Rows(i).Delete
End If

Next i


Range("F:F").HorizontalAlignment = xlLeft

DL3 = Cells(Application.Rows.Count, 1).End(xlUp).Row

Range("B4").Copy
    Range(Cells(4, 4), Cells(DL3, 4)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
With Range("D4:D" & DL3)
    .NumberFormat = "0.00"
    .Font.Size = 16
    .Font.Bold = True
    .Font.Color = RGB(255, 0, 0)
End With

With Range("B4:B" & DL3)
    .Font.Size = 16
    .Font.Bold = True
End With

With Range("F4:F" & DL3)
    .Font.Size = 16
    .Font.Bold = True
End With

With Range("H4:H" & DL3)
    .Font.Size = 16
    .Font.Bold = True
End With

With Range("A2:H3")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 11
End With

DL2 = Cells(Application.Rows.Count, 1).End(xlUp).Row

For T = 4 To DL2

Rows(T).RowHeight = 22.5

Next T

Range("A:J").ColumnWidth = 14
Range("A:H").ColumnWidth = 16
Range("F:F").ColumnWidth = 23
Range("B:B").ColumnWidth = 20
Range("E:E").ColumnWidth = 7
Range("G:G").ColumnWidth = 11
Range("I:I").ColumnWidth = 28
Range("J:J").ColumnWidth = 9


Rows(1).RowHeight = 28
With Range("A1:J1")
.Merge
.Font.Bold = True
.Font.Size = 20
.HorizontalAlignment = xlCenter
End With

Range("A1").Value = "VIREMENTS ECHEANCE " & Replace(DATE_ECHEANCE, "/", ".")

Rows(3).RowHeight = 20

Range("I2:I3").Merge
Range("J2:J3").Merge

Range("G2").Copy
    Range(Cells(2, 9), Cells(2, 10)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
Range("I2").Value = "Commentaires"

Range("J2").Value = "Valid."

    With Range("A1:J1").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

Range("A2").Select

End Sub


Pourquoi la partie : 

Range("A1").Value = "VIREMENTS ECHEANCE " & Replace(DATE_ECHEANCE, "/", ".")


Ne fonctionne-t-elle pas. en fait la valeur de A1 est "VIREMENTS ECHEANCE" et j'ai rien après. Comme si le code n'avait pas tenu compte de mon Userform...

Merci.
0

Discussions similaires

Le serveur a répondu par une erreur
Lilidore -
doremusli -

2 réponses