web-dev-qa-db-fra.com

Formatage des dates MM/JJ/AAAA dans la zone de texte de VBA

Je cherche un moyen de formater automatiquement la date dans une zone de texte VBA au format MM/JJ/AAAA, et je souhaite qu'elle soit formatée au fur et à mesure que l'utilisateur la tape. Par exemple, une fois que l'utilisateur a tapé le deuxième numéro, le programme tapera automatiquement un "/". Maintenant, j'ai ce travail (ainsi que le deuxième tiret) avec le code suivant:

Private Sub txtBoxBDayHim_Change()
    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End Sub

Maintenant, cela fonctionne très bien lorsque vous tapez. Cependant, lorsque vous essayez de supprimer, il entre toujours dans les tirets. Il est donc impossible pour l'utilisateur de supprimer l'un des tirets précédents (la suppression d'un tiret donne une longueur de 2 ou 5, et le sous-marin est ensuite exécuté à nouveau, en ajoutant un autre tiret). Des suggestions sur une meilleure façon de faire ceci?

excelvbaexcel-vbauser-interface
29
nobillygreen

Je ne suggère jamais d'utiliser des zones de texte ou des zones de saisie pour accepter les dates. Tant de choses peuvent aller mal. Je ne peux même pas suggérer d'utiliser le contrôle du calendrier ou le sélecteur de date, car vous devez enregistrer mscal.ocx ou mscomct2.ocx, ce qui est très pénible car ils ne sont pas distribués librement.

Voici ce que je recommande. Vous pouvez utiliser ce calendrier personnalisé pour accepter les dates de l'utilisateur.

AVANTAGES:

  1. Vous n'avez pas à vous soucier de la saisie par l'utilisateur des informations erronées
  2. Vous n'avez pas à vous soucier de l'utilisateur coller dans la zone de texte
  3. Vous n'avez pas à vous soucier d'écrire un code majeur
  4. Interface graphique attrayante
  5. Peut être facilement intégré à votre application
  6. N'utilisez pas de contrôles pour lesquels vous devez référencer des bibliothèques telles que mscal.ocx ou mscomct2.ocx

LES INCONVÉNIENTS:

Ummm ... Ummm ... Je ne peux penser à aucun ...

COMMENT L'UTILISER

  1. Téléchargez le Userform1.frm et le Userform1.frx à partir de ici .
  2. Dans votre VBA, importez simplement Userform1.frm comme indiqué dans l'image ci-dessous.

Importer le formulaire

enter image description here

EN COURS D'EXECUTION

Vous pouvez l'appeler dans n'importe quelle procédure. Par exemple

Sub Sample()
    UserForm1.Show
End Sub

COUPS D'ÉCRAN EN ACTION

enter image description here

NOTE: vous voudrez peut-être aussi voir Faire passer le calendrier à un nouveau niveau

57
Siddharth Rout

C'est le même concept que la réponse de Siddharth Rout. Mais je voulais un sélecteur de date entièrement personnalisable, de sorte que son apparence puisse être adaptée au projet utilisé.

Vous pouvez cliquer sur ce lien pour télécharger le sélecteur de date personnalisé que j'ai créé. Vous trouverez ci-dessous quelques captures d'écran du formulaire en action.

Three example calendars

Pour utiliser le sélecteur de date, importez simplement le fichier CalendarForm.frm dans votre projet VBA. Chacun des calendriers ci-dessus peut être obtenu avec un seul appel de fonction. Le résultat dépend uniquement des arguments que vous utilisez (tous optionnels), vous pouvez donc le personnaliser autant ou aussi peu que vous le souhaitez.

Par exemple, le calendrier le plus simple à gauche peut être obtenu à l'aide de la ligne de code suivante:

MyDateVariable = CalendarForm.GetDate

C'est tout ce qu'on peut en dire. À partir de là, il vous suffit d'inclure les arguments pour lesquels vous souhaitez obtenir le calendrier souhaité. L’appel de fonction ci-dessous générera le calendrier vert à droite:

MyDateVariable = CalendarForm.GetDate( _
    SelectedDate:=Date, _
    DateFontSize:=11, _
    TodayButton:=True, _
    BackgroundColor:=RGB(242, 248, 238), _
    HeaderColor:=RGB(84, 130, 53), _
    HeaderFontColor:=RGB(255, 255, 255), _
    SubHeaderColor:=RGB(226, 239, 218), _
    SubHeaderFontColor:=RGB(55, 86, 35), _
    DateColor:=RGB(242, 248, 238), _
    DateFontColor:=RGB(55, 86, 35), _
    SaturdayFontColor:=RGB(55, 86, 35), _
    SundayFontColor:=RGB(55, 86, 35), _
    TrailingMonthFontColor:=RGB(106, 163, 67), _
    DateHoverColor:=RGB(198, 224, 180), _
    DateSelectedColor:=RGB(169, 208, 142), _
    TodayFontColor:=RGB(255, 0, 0), _
    DateSpecialEffect:=fmSpecialEffectRaised)

Voici un petit aperçu de certaines des fonctionnalités qu’il inclut. Toutes les options sont entièrement documentées dans le module userform lui-même:

  • Facilité d'utilisation. Le formulaire utilisateur est complètement autonome et peut être importé dans n'importe quel projet VBA et utilisé sans autre codage supplémentaire.
  • Design simple et attrayant.
  • Fonctionnalité, taille et jeu de couleurs entièrement personnalisables
  • Limiter la sélection de l'utilisateur à une plage de dates spécifique
  • Choisissez n'importe quel jour pour le premier jour de la semaine
  • Inclure les numéros de semaine et la prise en charge de la norme ISO
  • En cliquant sur l'étiquette du mois ou de l'année dans l'en-tête, une liste déroulante sélectionnable s'affiche.
  • Les dates changent de couleur lorsque vous les survolez
31
Trevor Eyre

Ajoutez quelque chose pour suivre la longueur et vous permettre de "vérifier" si l'utilisateur ajoute ou soustrait du texte. Ceci n’a pas encore été testé, mais une solution similaire devrait fonctionner (surtout si vous avez un formulaire utilisateur).

'add this to your userform or make it a static variable if it is not part of a userform
private oldLength as integer

Private Sub txtBoxBDayHim_Change()
    if ( oldlength > txboxbdayhim.textlength ) then
        oldlength =txtBoxBDayHim.textlength
        exit sub
    end if

    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
    end if
    oldlength =txtBoxBDayHim.textlength
End Sub
11
enderland

Moi aussi, d’une manière ou d’une autre, nous sommes tombés sur le même dilemme, pourquoi diable Excel VBA n’a pas de Date Picker. Merci à Sid, qui a fait un travail extraordinaire pour créer quelque chose pour nous tous. 

Néanmoins, je suis arrivé à un point où j'ai besoin de créer le mien. Et je le publie ici car beaucoup de gens, j'en suis sûr, accèdent à ce poste et en tirent parti.

Ce que j'ai fait était très simple, comme ce que fait Sid, sauf que je n'utilise pas de feuille de travail temporaire. Je pensais que les calculs étaient très simples et simples, il n’était donc pas nécessaire de les jeter ailleurs. Voici le résultat final du calendrier:

enter image description here

Comment le configurer:

  • Créez 42 contrôles Label et nommez-les de manière séquentielle et disposés de gauche à droite, de haut en bas (cette étiquette contient 25 grisé jusqu'à 5 gris ci-dessus). Modifiez le nom des contrôles Label en Label_01, Label_02 et ainsi de suite. Définissez les 42 étiquettes Tag sur dts.
  • Créez 7 contrôles Label supplémentaires pour l'en-tête (cela contiendra Su, Mo, Tu ...)
  • Créez 2 contrôles Label supplémentaires, un pour la ligne horizontale (hauteur définie sur 1) et un pour l’affichage Month et Year. Nommez la Label utilisée pour afficher le mois et l'année Label_MthYr
  • Insérez 2 contrôles Image, l’un contenant l’icône de gauche pour faire défiler les mois précédents et l’autre, le mois prochain (je préfère les icônes représentant une flèche vers la gauche et la droite). Nommez-le Image_Left et Image_Right

La mise en page devrait ressembler plus ou moins à ceci (je laisse la créativité à quiconque l'utilisera).

enter image description here

Déclaration:  
Nous avons besoin d’une variable déclarée tout en haut pour que le mois en cours soit sélectionné.

Option Explicit
Private curMonth As Date

Procédure et fonctions privées: 

Private Function FirstCalSun(ref_date As Date) As Date
    '/* returns the first Calendar sunday */
    FirstCalSun = DateSerial(Year(ref_date), _
                  Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function

Private Sub Build_Calendar(first_sunday As Date)
    '/* This builds the calendar and adds formatting to it */
    Dim lDate As MSForms.Label
    Dim i As Integer, a_date As Date

    For i = 1 To 42
        a_date = first_sunday + (i - 1)
        Set lDate = Me.Controls("Label_" & Format(i, "00"))
        lDate.Caption = Day(a_date)
        If Month(a_date) <> Month(curMonth) Then
            lDate.ForeColor = &H80000011
        Else
            If Weekday(a_date) = 1 Then
                lDate.ForeColor = &HC0&
            Else
                lDate.ForeColor = &H80000012
            End If
        End If
    Next
End Sub

Private Sub select_label(msForm_C As MSForms.Control)
    '/* Capture the selected date */
    Dim i As Integer, sel_date As Date
    i = Split(msForm_C.Name, "_")(1) - 1
    sel_date = FirstCalSun(curMonth) + i

    '/* Transfer the date where you want it to go */
    MsgBox sel_date

End Sub

Événements d'image: 

Private Sub Image_Left_Click()

    If Month(curMonth) = 1 Then
        curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

Private Sub Image_Right_Click()

    If Month(curMonth) = 12 Then
        curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

J'ai ajouté ceci pour donner l'impression que l'utilisateur clique sur l'étiquette et doit également être inséré dans le contrôle Image_Right.

Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                 ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub

Événements de label:  
Tout ceci devrait être fait pour les 42 étiquettes (Label_01 à Lable_42)
Astuce: Construisez les 10 premiers et utilisez simplement trouver et remplacer pour le reste.

Private Sub Label_01_Click()
    select_label Me.Label_01
End Sub

C'est pour survoler les dates et cliquer sur l'effet.

Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BackColor = &H8000000B
End Sub

Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                             ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub

Evénements UserForm: 

Private Sub UserForm_Initialize()
    '/* This is to initialize everything */
    With Me
        curMonth = DateSerial(Year(Date), Month(Date), 1)
        .Label_MthYr = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

Encore une fois, juste pour l'effet de survol des dates.

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)

    With Me
        Dim ctl As MSForms.Control, lb As MSForms.Label

        For Each ctl In .Controls
            If ctl.Tag = "dts" Then
                Set lb = ctl: lb.BackColor = &H80000005
            End If
        Next
    End With

End Sub

Et c'est tout. C'est brut et vous pouvez y ajouter votre propre touche. 
Je l’utilise depuis un moment et je n’ai aucun problème (performances et fonctionnalités).
Pas encore Error Handling mais peut être facilement géré je suppose.
En fait, sans les effets, le code est trop court. 
Vous pouvez gérer où vont vos dates dans la procédure select_label. HTH.

4
L42

Pour une solution rapide, je fais habituellement comme ça.

Cette approche permettra à l’utilisateur de saisir la date dans n’importe quel format de son choix dans la zone de texte et, enfin, de formater au format mm/jj/aaaa une fois l’édition terminée. Donc c'est assez flexible:

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBox1.Text <> "" Then
        If IsDate(TextBox1.Text) Then
            TextBox1.Text = Format(TextBox1.Text, "mm/dd/yyyy")
        Else
            MsgBox "Please enter a valid date!"
            Cancel = True
        End If
    End If
End Sub

Cependant, je pense que Sid a mis au point une approche bien meilleure: un contrôle à part entière du sélecteur de dates.

2
Pradeep Kumar

Juste pour m'amuser, j'ai pris en considération la suggestion de Siddharth de séparer les zones de texte et de faire des listes déroulantes. Si cela vous intéresse, ajoutez un formulaire utilisateur avec trois listes déroulantes nommées cboDay, cboMonth et cboYear et organisez-les de gauche à droite. Collez ensuite le code ci-dessous dans le module de code de UserForm. Les propriétés de liste déroulante requises sont définies dans UserFormInitialization, aucune préparation supplémentaire n'est donc requise.

La partie délicate est de changer le jour où il devient invalide à cause d’un changement d’année ou de mois. Ce code le réinitialise simplement à 01 lorsque cela se produit et met en évidence cboDay.

Je n'ai rien codé comme ça depuis un moment. J'espère que cela intéressera quelqu'un, un jour. Sinon c'était amusant!

Dim Initializing As Boolean

Private Sub UserForm_Initialize()
Dim i As Long
Dim ctl As MSForms.Control
Dim cbo As MSForms.ComboBox

Initializing = True
With Me
    With .cboMonth
        '        .AddItem "month"
        For i = 1 To 12
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboDay
        '        .AddItem "day"
        For i = 1 To 31
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboYear
        '        .AddItem "year"
        For i = Year(Now()) To Year(Now()) + 12
            .AddItem i
        Next i
        .Tag = "DateControl"
    End With
    DoEvents
    For Each ctl In Me.Controls
        If ctl.Tag = "DateControl" Then
            Set cbo = ctl
            With cbo
                .ListIndex = 0
                .MatchRequired = True
                .MatchEntry = fmMatchEntryComplete
                .Style = fmStyleDropDownList
            End With
        End If
    Next ctl
End With
Initializing = False
End Sub

Private Sub cboDay_Change()
If Not Initializing Then
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboMonth_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboYear_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Function IsValidDate() As Boolean
With Me
    IsValidDate = IsDate(.cboMonth & "/" & .cboDay & "/" & .cboYear)
End With
End Function
Sub ResetDayList()
Dim i As Long
Dim StartDay As String

With Me.cboDay
    StartDay = .Text
    For i = 31 To 29 Step -1
        On Error Resume Next
        .RemoveItem i - 1
        On Error GoTo 0
    Next i
    For i = 29 To 31
        If IsDate(Me.cboMonth & "/" & i & "/" & Me.cboYear) Then
            .AddItem Format(i, "0")
        End If
    Next i
    On Error Resume Next
    .Text = StartDay
    If Err.Number <> 0 Then
        .SetFocus
        .ListIndex = 0
    End If
End With
End Sub

Sub ResetMonth()
Me.cboDay.ListIndex = 0
End Sub
2
Doug Glancy

Vous pouvez également utiliser un masque de saisie dans la zone de texte. Si vous définissez le masque sur ##/##/####, il sera toujours mis en forme au fur et à mesure de la frappe. Vous n'avez pas besoin de coder autre chose que de vérifier si ce qui a été entré était une date vraie.

Quelques lignes faciles

txtUserName.SetFocus
If IsDate(txtUserName.text) Then
    Debug.Print Format(CDate(txtUserName.text), "MM/DD/YYYY")
Else
    Debug.Print "Not a real date"
End If
2
Brad

Bien que je sois d’accord avec ce qui est mentionné dans les réponses ci-dessous, je suggère qu’il s’agit d’une très mauvaise conception pour Userform, à moins que de nombreuses vérifications d’erreur ne soient incluses ...

pour accomplir ce que vous devez faire, avec modifications minimes dans votre code, il existe deux approches.

  1. Utilisez KeyUp () event au lieu de Change event pour la zone de texte. Voici un exemple:

    Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    Dim TextStr As String
    TextStr = TextBox2.Text

    If KeyCode <> 8 Then ' i.e. not a backspace

        If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
            TextStr = TextStr & "/"
        End If

    End If
    TextBox2.Text = TextStr
End Sub

  2. Sinon, si vous devez utiliser l'événement Change () , utilisez le code suivant. Cela modifie le comportement de sorte que l'utilisateur continue à entrer les chiffres, comme 

    12072003

tandis que le résultat comme il tape apparaît comme

    12/07/2003

Mais le caractère '/' n'apparaît qu'une fois que le premier caractère du DD, à savoir 0 sur 07, est entré. Pas idéal, mais gérera toujours les espaces de retour.

    Private Sub TextBox1_Change()
        Dim TextStr As String

        TextStr = TextBox1.Text

        If (Len(TextStr) = 3 And Mid(TextStr, 3, 1) <> "/") Then
            TextStr = Left(TextStr, 2) & "/" & Right(TextStr, 1)
        ElseIf (Len(TextStr) = 6 And Mid(TextStr, 6, 1) <> "/") Then
            TextStr = Left(TextStr, 5) & "/" & Right(TextStr, 1)
        End If

        TextBox1.Text = TextStr
    End Sub
1
hnk
Private Sub txtBoxBDayHim_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then 'only numbers and backspace
    If KeyAscii = 8 Then 'if backspace, ignores + "/"
    Else
        If txtBoxBDayHim.TextLength = 10 Then 'limit textbox to 10 characters
        KeyAscii = 0
        Else
            If txtBoxBDayHim.TextLength = 2 Or txtBoxBDayHim.TextLength = 5 Then 'adds / automatically
            txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
            End If
        End If
    End If
Else
KeyAscii = 0
End If
End Sub

Cela fonctionne pour moi. :)

Votre code m'a beaucoup aidé. Merci!

Je suis brésilienne et mon anglais est pauvre, désolé de toute erreur.

1
Lucas