transformer un textbox en Datebox

[patricktoulon]

Bonjours a tous
je vous propose ce petit code pour transformer un textbox en Datebox

il faut seulement que le texte"__/__/____" soit présent dans le textbox

seules les touches du pavé numérique ,back et suppr sont acceptées

vous tapez si a un moment la partie tapée n'est pas valide la fonction bloque la sélection sur la partie en faute
vous retapez sans rien toucher ni souris ou touche pour se repositionner
les touche back et suppr font leur boulot initial sauf que le masque de saisie se remet en place

derniere mise a jour 26/06/2018
---------------------------------------------------------------------------------

Option Explicit

Private Sub control_saisie(ByRef txt As Object, KeyCode)
    Dim T$, X&, Z&, i&
    With txt
        T = Mid(.Text, 1, 10): X = .SelStart
        Select Case KeyCode
        Case 8
            KeyCode = 0
            If .SelLength > 0 Then Exit Sub
            If X = 0 Then X = 1:
            If Mid(T, X, 1) <> "/" Then Mid(T, X, 1) = "_" Else Mid(T, X, 1) = "/":
            .Text = T: .SelStart = X - IIf(X > 0, 1, 0)
        Case 46
            KeyCode = 0
            If .SelLength > 0 Then For i = X To X + .SelLength - 1: Mid(T, i + 1, 1) = IIf(Mid(T, i + 1, 1) <> "/", "_", "/"): Next: .Text = T: .SelStart = X: KeyCode = 0: Exit Sub
        If X < 10 And Mid(T, X + 1, 1) <> "/" Then Mid(T, X + 1, 1) = "_": .Text = T: .SelStart = X + 1 Else .SelStart = X + 1
    Case 96 To 105, 48 To 57
        If .SelLength > 0 Then
            Mid(T, X + 1, .SelLength) = Chr(KeyCode - IIf(KeyCode < 96, 0, 48)) & Left("____", .SelLength - 1): .Text = T: .SelStart = X + 1: KeyCode = 0
        Else
            Z = InStr(1, T, "_"): If Z = 0 Then KeyCode = 0: Exit Sub
            Mid(T, Z, 1) = Chr(KeyCode - IIf(KeyCode < 96, 0, 48)): .Text = T: KeyCode = 0: .SelStart = IIf(Mid(T, Z + 1, 1) = "/", Z + 1, Z)
        End If
        If Val(Mid(T, 1, 1)) > 3 Then Mid(T, 1, 2) = "__": .Text = T: .SelStart = 0:    '.SelLength = 2
        If Val(Mid(T, 4, 1)) > 3 Then Mid(T, 4, 2) = "__": .Text = T: .SelStart = 3:    '.SelLength = 2
        If Val(Mid(T, 1, 2)) > 31 Then Mid(T, 1, 2) = "__": .Text = T: .SelStart = 0:    '.SelLength = 2
        If Val(Mid(T, 1, 2)) > 12 And Val(Mid(T, 4, 1)) > 1 Then Mid(T, 4, 2) = "__": .Text = T: .SelStart = 3:    '.SelLength = 2
        If Not Mid(T, 1, 6) Like "*_*" And Not IsDate(Mid(T, 1, 6) & "2000") Then Mid(T, 4, 2) = "__": .Text = T: .SelStart = 3:    '.SelLength = 2 ' Else '.SelStart = InStr(1, T, "_")
        If Not T Like "*_*" Then
            If Not IsDate(T) Then Mid(T, 7, 4) = "____": .Text = T: .SelStart = 6: Exit Sub   ' .SelLength = 1
            If Val(Year(T)) <> Val(Mid(T, 7, 4)) Then Mid(T, 7, 4) = "____": .Text = T: .SelStart = 6:
        End If
    Case Else: KeyCode = 0: Exit Sub
    End Select
End With
End Sub
'
'

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_saisie TextBox1, KeyCode
End Sub

--------------------------------------------------------------------------------------------------------------------------

 

[JM27]

bonsoir
bien sur Job tu as raison
le 20 ème c'est les année 1900
Le 21 ème c'est les années 2000

 

[JM27]

Bonsoir
@patricktoubon
quand tu tapes 29/02/2000
année bissextile : OK
Quant tu remplaces 29 par 30 et que tu appuie sur validation : as tu le message date validée ????
pour l'ergonomie je trouve au contraire que c'est top ( beaucoup d'utilisateurs apprécient)
mais c'est bien d'essayer de"vendre " ton truc (usine à gaz)

pour ta saisie il est ou le focus dans ton userform
et tu en conviendra que niveau ergonomie c'est pas top (obligé de reprendre la souris et de selectionner )

un peu tétu :

non je peut t'assurer qu'avec ton code comme tel t'a tout faux en aucune manière tu a sécurisé la validité il faut aller beaucoup plus loin que ca

donnes moi des exemple de dates non correctes
comme disait mon patron " speak with data "
e tu as mis le doit sur un message manquant voici une modif

 

[patricktoulon]

re JM27
imagine tu fait une application ou un site dans le quel tu met un formulaire avec
nom
prenom
age
date de naissance
etc..
etc...
et moi qui ai 48 ans né en 1970 je fait quoi si je peux pas aller en dessous de 2000 dans ton textbox , je m'inscrit pas c'est ça ???? je suis trop vieux hihihihihi!!!!

je veux pas absolument vendre mon truc d'ailleurs c'est gratuit , je pointe seulement du doigt dans ce principe
les erreurs monumentales est catastrophique que peuvent générer un tel algo

imagine l’état catastrophé de l' utilisateur essayant de remplir un formulaire pour s'inscrire avec des textboxs qui ne veulent pas de sa saisie malgré qu'elle soit bonne hihihihi
si c'est a moi que ca arrive ,je mange mon clavier la hihihihi
imagine que au dessus du formulaire il y a """plus que 30 seconde pour s'inscrire et gagner un iphone""" hihihihihihihi!!!!

je le redis """POUR UN DATEBOX IL FAUT ALLER PLUS LOIN QUE CA """
pouvoir taper nimporte quelle date
pouvoir revenir sur le mois le jour l'année
ne pas pouvoir supprimer les séparateurs si il sont présent pour un date box sans masque ("/")
pouvoir revenir avec la touche back a sa guise au cas ou
l'utilisateur aurait tapé par exemple 13 a la place de 12(problème de gros doigts ou syndrome de la tourrette )

non vraiment un Control de saisie dans un simple select case ca ne peut pas suffire

un datebox on doit pouvoir revenir dans tout les sens sans générer de blocage ou d'erreur de plantage
après
vous faite ce que vous voulez réfléchissez seulement au conséquences même pour vous même

en tout cas merci a tous pour vos retours ça me permet d'imaginer toutes les mauvaises manip qu'un utilisateur pourrait faire
vous êtes au top changez rien c'est agréable les gens sympa

 

[JM27]

Bon allez je laisse tomber
tu n'as rien compris désolé
tu te permet de critiquer un programme de cathodique sans même l'avoir testé
c'est toi qui le dit

avant même de l'essayer je savais que c’était pas bon

et l'on se rend compte par la suite que tu ne connais pas le fonctionnement

a d'accord je comprends mieux il ne faut taper que les deux dernier de l’année sinon je suis bloqué a 2020

et pour terminer dans ton dernier post

et moi qui ai 48 ans né en 1970 je fait quoi si je peux pas aller en dessous de 2000 dans ton textbox , je m'inscrit pas c'est ça ???? je suis trop vieux hihihihihi!!!!

as tu au moins essayé
pour info essayes de lire avant de critiquer : regarde le label devant la textboxdate
nota : j'attends des dates incorrectes
essayes de lire le code , de le comprendre et tu verrsa que l'on peut facilement modifier la date de début et de fin

 

[patricktoulon]

oui j'ai regarder le code et oui de toute facon a moins de protéger le vbproject on peu toujours modifier le code

mais comme je l'ai dis c'est bien pour un control saisie en progression mais pas pour un datebox

pour la simple et bonne raison que la verif se fait dans un select case simple

comme je l'ai dis tout a l'heure tape un date complète (valide c'est important) et reviens dessus le mois ou même le jours en mettant un jour ou un mois trop grand trop grand

c'est pas le même principe un datebox et un control de saisie progressif)

voir mise a jour en post 1 avec animation

une date incorrect par exemple 29/02/0029 comme je n'ai pas pu passer en dessous de 2000 je n'ai pas pu testé
mais en regardant le code il te manque un test de toute les facons ca c'est sur et certain
et pour t'en rendre compte voici une petite sub qui va jusqu'a 1000
lance ca dans un fichier vierge
en colonne A tu a une date
en colonne B tu a le resultat de ISDATE
et en colonne C tu a l'année que isdate interprète ce qui te donne une idée du pourquoi de temps en temps isdate va te dire vrai alors que non

j’espère que ca te donnera un aperçu suffisant pour te faire comprendre ce que j'essai de te faire comprendre avec isdate
quand il i a des trou c'est que vraiment year(...) declenche une erreur car la date n'est meme pas interprétée et donc year(vide) donne forcement une erreur

Sub test2()
For i = 1 To 1000
Cells(i, 1) = "29/02/" & Format(i, "0000")
Cells(i, 2) = IsDate(Cells(i, 1).Value)
On Error Resume Next
Cells(i, 3) = Year(Cells(i, 1).Value)
On Error GoTo 0
Next
End Sub

 

[JM27]

j'attends des dates incorrectes

 

[patricktoulon]

pour te donner une idée du problème entre la validation progressif dans un select case simple et un select case amélioré
voila une animation de ton userform


ca avec le mien tu ne peut pas le faire
un autre exemple de drolerie que j'obtiens avec ton model
je ta toujours une bonne date et je supprime le jour et mois et le message me dit que
"" les mois ne peuvent pas etre plus grand que 12 """

 

[JM27]

Et le bouton validation , il sert à rien ?

 

[patricktoulon]

une date non valide oui OK ALORS 29/02/0025 si tu arrive a la taper
une autre drôlerie qui prouve bien que jouer avec les fonctions date n'est pas évident
j'ai baissé TA datemin a 1001
regarde dans le label bleu comment elle est interprétée

 

[mapomme]

Bonjour à tous,

Pour le fun, une méthode que j'avais utilisée pour "essayer de garantir la saisie correcte d'une date". les séparateurs sont chacun un seul caractère non numérique (slash, espace, tiret, virgule ...). Les dates à année inférieure à 100 sont considérées comme faisant partie du 21ème siècle.
Valider la date en appuyant sur la touche Entrée.
nota : fourni tel quel sans certitude...

 

[patricktoulon]

re
avec 29/02/0025 non il ne sert a rien puisque isdate va le donner bon
et un datebox n'a pas besoins de bouton valider
ce que tu pourrais ajouter dans le tiens dans le case 8 et je dirais plutot 10
c'est les deux tests des cases précédents comme ça même si on reviens dessus le jour ou le mois ils sont contrôlés même si on a plus que 6 caracteres

et pour 1001 qui est pris pour 2100 on fait comment ?

après c'est vrai que l'on parle pas de la même chose
tu parle d'un textbox que tu control en cours de saisie de 1 a len(6) puis 8 et tu Controle par un bouton

moi je parle d'un textbox qui est contrôle caractères par caractère et cela en cours de rédaction ou en réédition , ca n'a strictement rien a voir comme approche
et chez toi il n'y a pas de gestion du back il est même inhiber ,ni de SUPPR d'ailleurs
autrement dit on se trompe on refait tout

au final dans le mien quand il n'y a plus de masque ("_") , elle est forcement valide pas besoins de bouton ou autre, le textbox le fait tout seul
c'est un peu plus difficile a faire sans masque mais je pense que c'est possible

réfléchi a tes test case tu aura déjà ajouté ca

après avec ce model je pense pas que l'on pourrait faire beaucoup plus

 

[patricktoulon]

Bonjour a tous
voici la version final qui a été épurée et revue entièrement la stratégie en terme de raisonnement et donc de code

1. gestion des touches flèches gauche et droite
2. gestion de la touche back
3. gestion de la touche suppr
4. gestion de la touche Enter et Tab
5. gestion du pavé numérique (en majuscule rangée du haut du clavier)
6. auto sélection
7. beep d'avertissement si c'est pas valide en cours de saisie ou en correction et sélection automatique
8. il est impossible désormais de taper une date erronée
9. le code est Largement plus léger je l'ai aéré par étape

Option Explicit
Sub control_saisie3(txt As Object, KeyCode)
    Dim T As String, X&, I&, Xl&, J&, M&, A&, ldate, temp
    With txt
        If txt = "" Then txt = "__/__/____"    'au cas ou le masque n'y serait pas au depart
        T = .Value
        If T Like "__/__/____" Then .SelStart = 0
        X = .SelStart: Xl = .SelLength
        If X + 1 > 11 Then KeyCode = 0
        If KeyCode >= 48 And KeyCode <= 57 Then KeyCode = KeyCode + 48    ' pour ce qui n'ont pas le pavé numerique et se servent des chiffre en haut de clavier
        Select Case KeyCode

            '_____________________________________________________________________________________________________
            'Gestion de la Touche back(retours en arrière)
        Case 8
            KeyCode = 0
            X = Switch(X >= 7, 6, X <= 3, 0, X >= 3 And X <= 6, 3): Xl = IIf(X = 6, 4, 2)
            Mid(T, X + 1, Xl) = Left("____", Xl): .Value = T: .SelStart = X: .SelLength = Xl


            '_____________________________________________________________________________________________________
            'Gestion de la Touche suppr(supprimer)
        Case 46
            If Xl < 2 Then Mid(T, X + 1, 1) = IIf(Mid(T, X + 1, 1) = "/", "/", "_"): KeyCode = 0: .Value = T: .SelStart = X
            If Xl > 0 Then For I = X To X + Xl - 1: Mid(T, I + 1, 1) = IIf(Mid(T, I + 1, 1) <> "/", "_", "/"): Next: .Value = T: .SelStart = X
        If T Like "__/__/____" Then .SelStart = 0
        KeyCode = 0


        '_____________________________________________________________________________________________________
        'Gestion  des touches du  pavé numerique(haut et bas)
    Case 96 To 105
        Select Case X
        Case 0 To 1, 3 To 4, 6 To 9
            If Xl = 1 Then Mid(T, X + 1, 1) = Chr(KeyCode - 48): .Value = T: .SelStart = X + 1
            If Xl > 1 Then X = IIf(X < 6, IIf(X <= 1, 0, 3), 6): Mid(T, X + 1, Xl) = Chr(KeyCode - 48) & Left("____", Xl - 1): .Value = T: .SelStart = X + 1:
            If Xl = 0 Then Mid(T, X + 1, 1) = Chr(KeyCode - 48): .Value = T: .SelStart = X + 1:
            KeyCode = 0
        Case Else: KeyCode = 0
        End Select
        If Mid(T, X + 2, 1) = "/" Then .SelStart = X + 2
        KeyCode = 0

        '_____________________________________________________________________________________________________
        'controle de date valide
        J = Val(Mid(T, 1, 2)): M = Val(Mid(T, 4, 2)): A = IIf(T Like "*_*", 2000, Val(Mid(T, 7, 4)))
        If M > 12 Then temp = J: J = M: M = temp
        If Val(T) > 31 Or Val(Mid(T, 1, 1)) > 3 Then Mid(T, 1, 2) = "__": .Value = T: .SelStart = 0: .SelLength = 2: Beep
        If Val(Mid(T, 4, 2)) > 31 Or Val(Mid(T, 4, 1)) > 3 Then Mid(T, 4, 2) = "__": .Value = T: .SelStart = 3: .SelLength = 2: Beep
        If Val(J) > 0 And Val(M) > 0 Then
            ldate = DateSerial(A, M, J)
            If (J > 12 And M > 12) Or Month(ldate) <> M Or Day(ldate) <> J Or Year(ldate) <> A Then
                If X = 3 Or X = 4 Then Mid(T, 4, 2) = "__": .Value = T: .SelStart = 3: .SelLength = 2: Beep: KeyCode = 0: Exit Sub
                If X <= 2 Then Mid(T, 1, 2) = "__": .Value = T: .SelStart = 0: .SelLength = 2: Beep: KeyCode = 0: Exit Sub
                If X >= 5 Then Mid(T, 7, 4) = "____": .Value = T: .SelStart = 6: .SelLength = 4: Beep: KeyCode = 0: Exit Sub
            End If
        End If


        '_____________________________________________________________________________________________________
        'gestion de la Touche fleche gauche
    Case 37:
        KeyCode = 0
        If X <= 5 Then .SelStart = 0: txt.SelLength = 2 Else If X > 5 Then .SelStart = 3: txt.SelLength = 2

        '_____________________________________________________________________________________________________
        'Gestion de la Touche fleche droite
    Case 39:
        KeyCode = 0
        If X <= 2 And Mid(T, 1, 2) <> "__" Then .SelStart = 3: txt.SelLength = 2 Else If X >= 3 Then .SelStart = 6: txt.SelLength = 4


        '_____________________________________________________________________________________________________
        'Gestion des Touches ENTER et TAB
    Case 13, 9
        If InStr(txt.Value, "_") Then KeyCode = 0
        '_____________________________________________________________________________________________________
        'Gestion des  autres touches
    Case Else
        KeyCode = 0
        '-----------------------------------------------------------------------------------------------------

    End Select
End With
End Sub

les format acepté sont dd/mm/yyyy ou mm/dd/yyyy

on appelle cette sub dans l’événement keydown du textbox

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisie3 TextBox1, KeyCode
End Sub

on est loin des classes et autre essais (usines a gaz que l'on trouve ici et la )

 

[Si...]

Salut

après avec ce model je pense pas que l'on pourrait faire beaucoup plus

Allez, encore un petit effort…