Comment puis-je créer une entrée de calendrier dans VBA Excel?

Question

Énoncé du problème

Dans VBA, trois types principaux de contrôles de date et d'heure peuvent être utilisés à condition que certains ocx aient été enregistrés à l'aide de droits d'administrateur . Ce sont des contrôles VB6 et ne sont pas natifs de l'environnement VBA. Pour installer le Montview Control et Datetime Picker, nous devons définir une référence à Microsoft MonthView Control 6.0 (SP4) qui n'est accessible que par un enregistrement élevé de mscomct2.ocx. De même pour mscal.ocx et mscomctl.ocx. Cela dit, le mscal.ocx déconseillé peut ou non fonctionner sur Windows 10.

En fonction de vos versions Windows et Office (32 bits ou 64 bits), il peut être très difficile d'enregistrer ces ocx.

Le contrôle Monthview, Datetime Picker et le contrôle obsolète Calendar sont présentés ci-dessous.

Alors, quel problème puis-je rencontrer si je les inclue dans mon application?

Si vous les incluez dans votre projet et les distribuez à vos amis, voisins, clients, etc., l'application peut ou non fonctionner selon qu'ils ont ces ocx installés.

Et donc il est fortement conseillé [~ # ~] et non [~ # ~] de les utiliser dans votre projet

Quelle (s) alternative (s) ai-je?

Ce calendrier, utilisant Userform et Worksheet , a été suggéré plus tôt et est incroyablement basique.

Quand j'ai vu le calendrier Windows 10 qui s'est affiché lorsque j'ai cliqué sur la date et l'heure dans la barre d'état système, je n'ai pas pu m'empêcher de me demander si nous pouvions reproduire cela dans VBA.

Cet article explique comment créer un calendrier widget qui ne dépend d'aucun ocx ou 32bit/64bit et qui peut être distribué librement avec votre projet.

Voici à quoi ressemble le calendrier dans Windows 10:

et voici comment vous interagissez avec elle:

Answer 1

L'exemple de fichier (ajouté à la fin de l'article) a un Userform, un module et un module de classe. Pour l'incorporer dans votre projet, il vous suffit d'exporter le formulaire utilisateur, le module et le module de classe à partir du fichier d'exemple et de l'importer dans votre projet.

Code de module de classe

Dans le module de classe (appelons-le CalendarClass) collez ce code

Public WithEvents CommandButtonEvents As MSForms.CommandButton

'~~> Unload the form when the user presses Escape
Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Not f Is Nothing Then If KeyAscii = 27 Then Unload f
End Sub

'~~> This section delas with showing/displaying controls
'~~> and updating different labels
Private Sub CommandButtonEvents_Click()
    f.Label6.Caption = CommandButtonEvents.Tag

    If Left(CommandButtonEvents.Name, 1) = "Y" Then
        If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then
            CurYear = Val(CommandButtonEvents.Caption)                
            With f
                .HideAllControls
                .ShowMonthControls

                .Label4.Caption = CurYear
                .Label5.Caption = 2

                .CommandButton1.Visible = False
                .CommandButton2.Visible = False
            End With
        End If
    ElseIf Left(CommandButtonEvents.Name, 1) = "M" Then
        Select Case UCase(CommandButtonEvents.Caption)
            Case "JAN": CurMonth = 1
            Case "FEB": CurMonth = 2
            Case "MAR": CurMonth = 3
            Case "APR": CurMonth = 4
            Case "MAY": CurMonth = 5
            Case "JUN": CurMonth = 6
            Case "JUL": CurMonth = 7
            Case "AUG": CurMonth = 8
            Case "SEP": CurMonth = 9
            Case "OCT": CurMonth = 10
            Case "NOV": CurMonth = 11
            Case "DEC": CurMonth = 12
        End Select

        f.HideAllControls
        f.ShowSpecificMonth
    End If
End Sub

Code du module

Dans le module (appelons-le CalendarModule) collez ce code

Option Explicit

Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Private Declare Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #End If

    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
    (ByVal hwnd As LongPtr) As LongPtr

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

    Private Declare PtrSafe Function SetTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
    ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr

    Public Declare PtrSafe Function KillTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr

    Public TimerID As LongPtr

    Dim lngWindow As LongPtr, lFrmHdl As LongPtr
#Else

    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

    Public Declare Function FindWindowA _
    Lib "user32" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

    Public Declare Function SetTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    Public Declare Function KillTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

    Public TimerID As Long
    Dim lngWindow As Long, lFrmHdl As Long
#End If

Public TimerSeconds As Single, tim As Boolean
Public CurMonth As Integer, CurYear As Integer
Public frmYr As Integer, ToYr As Integer

Public f As frmCalendar

Enum CalendarThemes
    Venom = 0
    MartianRed = 1
    ArcticBlue = 2
    Greyscale = 3
End Enum

Sub Launch()
    Set f = frmCalendar

    With f
        .Caltheme = Greyscale
        .LongDateFormat = "dddd dd. mmmm yyyy" '"dddd mmmm dd, yyyy" etc
        .ShortDateFormat = "dd/mm/yyyy"  '"mm/dd/yyyy" or "d/m/y" etc
        .Show
    End With
End Sub

'~~> Hide the title bar of the userform
Sub HideTitleBar(frm As Object)
    #If VBA7 Then
        Dim lngWindow As LongPtr, lFrmHdl As LongPtr
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLongPtr(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLongPtr(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #Else
        Dim lngWindow As Long, lFrmHdl As Long
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #End If
End Sub

'~~> Start Timer
Sub StartTimer()
    '~~ Set the timer for 1 second
    TimerSeconds = 1
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub

'~~> End Timer
Sub EndTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
End Sub

'~~> Update Time
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As LongLong, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As LongLong)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#Else ' 32 bit Excel
    Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
    ByVal nIDEvent As Long, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#End If

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
    ' Purpose: get weekday in "DDD" format
    wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
    ' Example call: mon(12, "1031") or mon(12, "de")
    mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(3) International patterns
Function cPattern(ByVal ctry As String) As String
    ' Purpose: return country code pattern for above functions mon() and wday()
    ' Codes: see https://msdn.Microsoft.com/en-us/library/dd318693(VS.85).aspx
    ctry = LCase(Trim(ctry))
    Select Case ctry
        Case "1033", "en-us": cPattern = "[$-409]" ' English (US)
        Case "1031", "de": cPattern = "[$-C07]" ' German
        Case "1034", "es": cPattern = "[$-C0A]" ' Spanish
        Case "1036", "fr": cPattern = "[$-80C]" ' French
        Case "1040", "it": cPattern = "[$-410]" ' Italian
        ' more ...
    End Select
End Function

Code de formulaire utilisateur

Le code Userform (appelons-le frmCalendar) est trop gros pour être publié ici. Veuillez vous référer à l'exemple de fichier.

Capture d'écran

Thèmes

Faits saillants

1. Pas besoin d'enregistrer une dll/ocx.
2. Facilement distribuable. Ce est gratuit.
3. Aucun droit d'administration requis pour l'utiliser.
4. Vous pouvez sélectionner un habillage pour le widget de calendrier. On peut choisir parmi 4 thèmes Venom, MartianRed, ArticBlue et GreyScale.
5. Choisissez la langue pour voir le nom du mois/jour. Prise en charge de 4 langues.
6. Spécifiez des formats de date longs et courts

Exemple de fichier

fichier d'exemple

Remerciements @ Pᴇʜ, @chrisneilsen et @ T.M. pour avoir suggéré des améliorations.

Quoi de neuf :

Bogues signalés par @RobinAipperspach et @Jose corrigés

Answer 2

Obtenez les noms internationaux des jours et des mois

Cette réponse est destinée à être utile à l'approche de Sid concernant l'internationalisation ; donc il ne répète pas les autres parties de code que je considère comme suffisamment claires pour construire un UserForm. Si vous le souhaitez, je peux le supprimer après incorporation dans Vers. 4.0.

En plus de la solution valide de Sid, je démontre un code simplifié pour obtenir les noms internationaux des jours de la semaine et du mois - c.f. afficher dynamiquement les noms des jours de la semaine dans la langue native d'Excel

Procédure ChangeLanguage modifiée dans le module du formulaire frmCalendar

Sub ChangeLanguage(ByVal LCID As Long)
    Dim i&
    '~~> Week Day Name
     For i = 1 To 7
         Me.Controls("WD" & i).Caption = Left(wday(i, LCID), 2)
     Next i
    '~~> Month Name
     For i = 1 To 12
         Me.Controls("M" & i).Caption = Left(mon(i, LCID), 3)
     Next i
End Sub

Fonctions appelées dans CalendarModule

Ces trois fonctions pourraient remplacer la fonction LanguageTranslations(). Avantage: code court, moins de mémoire, maintenance plus facile, noms corrects

'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
' Purpose: get weekday in "DDD" format
  wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
' Example call: mon(12, "1031") or mon(12, "de")
  mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'(3) International patterns
Function cPattern(ByVal ctry As String) As String
' Purpose: return country code pattern for above functions mon() and wday()
' Codes: see https://msdn.Microsoft.com/en-us/library/dd318693(VS.85).aspx
ctry = lcase(trim(ctry))
Select Case ctry
  Case "1033", "en-us"
    cPattern = "[$-409]" ' English (US)
  Case "1031", "de"
    cPattern = "[$-C07]" ' German
  Case "1034", "es"
    cPattern = "[$-C0A]" ' Spanish
  Case "1036", "fr"
    cPattern = "[$-80C]" ' French
  Case "1040", "it"
    cPattern = "[$-410]" ' Italian
' more ...
End Select
End Function

Answer 3

Ceci est mon premier post ici. Je me sentais obligé de partager car la perte du calendrier dans Excel était une affaire énorme et ce calendrier créé par SiddhartRout est incroyable. Donc, BEAUCOUP merci à @SiddhartRout pour avoir préparé ce calendrier vraiment incroyable. J'ai apporté des modifications aux cosmétiques, mais la majeure partie de la viande sous-jacente est toujours le travail de Siddhart avec quelques changements mineurs pour répondre à mon cas d'utilisation.

Changements cosmétiques :

• Remplacement de TOUS les boutons par des étiquettes sans bordure pour qu'il ressemble beaucoup plus au calendrier de Windows 10
• La bordure des étiquettes apparaîtra/disparaîtra lors de l'entrée/sortie de la souris
• J'ai grisé les jours qui ne sont pas pour le mois en cours. Le "gris" est une couleur différente qui correspond mieux à chaque thème.
• Modification des couleurs du thème à mon goût. Ajout d'une étiquette sur laquelle cliquer pour parcourir les thèmes.
• Changé la police en Calibri
• changement de couleur ajouté à l'entrée de la souris aux commandes mois/année et flèches
• Utilisez ce site pour tous vos besoins de codes de couleur -> codes de couleurs RVB

Modifications du code

• Optimisation de la propriété Let Caltheme facilitant la configuration et l'ajout de couleurs de thème ou de thèmes entièrement nouveaux
• Je n'ai pas réussi à faire fonctionner l'ESC de manière fiable, je l'ai donc remplacé par un `` X ''. Il a également cessé de s'écraser.
• Suppression des trucs de localisation car je n'en aurai jamais besoin
• Le passage des boutons aux libellés a nécessité la modification de certaines variables d'objet si nécessaire tout au long du projet
• Ajout de variables publiques utilisées pour stocker les valeurs RVB permettant l'utilisation des couleurs de thème tout au long du projet pour une application plus cohérente et plus facile du thème sélectionné
• Le thème sélectionné par l'utilisateur est stocké dans la feuille masquée, il est donc persistant entre les exécutions
• Suppression du bouton de coche et lancement directement à partir d'un clic n'importe quel jour.

Captures d'écran de chaque thème:

Lien de téléchargement du code:

• Win10ExcelCal.xlsm