transformer un textbox en Datebox

patricktoulon · 25 Juin 2018

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
---------------------------------------------------------------------------------

Code:

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

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

Lone-wolf · 25 Juin 2018

Bonsoir tous ce beau monde

@patricktoulon : je suis étonné que personne aie fait la remarque concernant le code en dur.

Pour une meilleure visualisation, clique sur l'icône en forme de feuille à côte de l'icone enregistrer.
Choisi Code, puis VB et insère le code.

cathodique · 25 Juin 2018

patricktoulon à dit:
re
oulah catodique si c’était si simple tu peux me croire je ne me serais pas embête
avant même de l'essayer je savais que c’était pas bon
malheureusement isdate n'est pas suffisant pour contrôler la date complète
avec ton truc essaie de taper 29/02/2001 ou même 29/02/0009 qui je te le dit tout de suite sont fausses
alors essaie ca
msgbox isdate("29/02/2001") va te donner faux hors toi avec ton code tu la donne bonne
msgbox isdate("29/02/0009") va te donner bon hors elle est fausse et ton code donne aussi bon

d'autre part le controle jour et mois se fait que lorsque tu a tapé 2 chiffres pour l'année exemple:
ce n'est qu'arrivé a "30/02/20" que l'erreur va être révélé et c'est normal car avec le keypress le update du textbox n'est pas effectué lors de la pression sur la touche il l'est uniquement lors du keyUP

d'autre part tu interdit plus petit que 12 si plus grand pour le mois
il se trouve que si un américain veux utiliser ton code il sera chocolat car au états unis le format date c'est mois/jour/année
on pers des l'ors l'universalité et même certain utilisateur français ont un os en version anglosaxon

voila déjà pour un début
je veux bien t'aider a améliorer ta version si tu veux sans masque

Mon cher Patrick, je n'ai jamais pensé à ton approche (années bissextiles).
Merci, pour tes critiques. houlala, j'avais tout faux. Merci beaucoup.

ps: c'est un code que j'utilisais mais depuis j'ai opté pour un calendrier autonome.
Mais ça, m’intéresserai d'améliorer le code de mon précédent post, ne serait-ce que pour ne pas mourir idiot.

Bonne soirée.

cathodique · 25 Juin 2018

Lone-wolf à dit:
Bonsoir tous ce beau monde

@patricktoulon : je suis étonné que personne aie fait la remarque concernant le code en dur.

Pour une meilleure visualisation, clique sur l'icône en forme de feuille à côte de l'icone enregistrer.
Choisi Code, puis VB et insère le code.

Salut Lone-wolf, où est le gentil chat?!
Effectivement, je n'avais pas pensé de le souligner à notre ami PatrickToulon qu'on pouvait améliorer la publication du code.
Merci de l'avoir fait.

Bonne soirée à toutes et à tous

Lone-wolf · 25 Juin 2018

Re tout le monde

@cathodique

Me revoilà!

@patricktoulon

et même certain utilisateur français ont un OS en version anglosaxon

Alors les français doivent avoir de (os - sérieux problèmes) avec leurs ordis.

patricktoulon · 25 Juin 2018

le minou bonjour
@cathodique

cathodique à dit:
Mon cher Patrick, je n'ai jamais pensé à ton approche (années bissextiles).
Merci, pour tes critiques. houlala, j'avais tout faux. Merci beaucoup.

ps: c'est un code que j'utilisais mais depuis j'ai opté pour un calendrier autonome.
Mais ça, m’intéresserai d'améliorer le code de mon précédent post, ne serait-ce que pour ne pas mourir idiot.

Bonne soirée.

re
allez j'ai repris ton idée de msgbox
a une différence près c'est que la mienne peut valider les deux formats "31/12/xxxx ou 12/31/xxxx
bien entendu elle gère les années bissextiles par les 2 test isdate et year(text.value)<> du val(right(txt.value,4)) POUR LE CASE 10!!!

voila la bete

Code:

Private Sub TextBox1_KeyPress(ByVal Touche As msforms.ReturnInteger)
    If InStr("0123456789", Chr(Touche)) = 0 Then Touche = 0
End Sub

'Controle validité de la date saisie
Private Sub TextBox1_change()
    ValidationDate TextBox1
End Sub

' =============== Routine de validation de date à la saisie dans Textbox ============
'================              Dans un module standard                   ============
'
Public Sub ValidationDate(txt As Object)
    Static mem As String
 
    txt.Value = Mid(txt.Value, 1, 10)
 
    If Val(Mid(txt.Value, 1, 2)) > 12 And Val(Mid(txt.Value, 4, 1)) > 1 Then txt.Value = Left(txt.Value, 3)
 
    Select Case Len(txt.Value)
    Case 1, 4
         If CLng(Right(txt.Value, 1)) > 3 Then
            MsgBox "c'est pas bon!!! " & IIf(Len(txt.Value) < 3, " le jour", " le mois")
            txt.Value = Left(txt.Value, Len(txt) - 1)
        End If

    Case 2, 5
        If CLng(Right(txt, 2)) > 31 Then
            MsgBox "c'est pas bon!!!" & IIf(Len(txt.Value) < 3, " le jour", " le mois")
            txt.Value = Left(txt.Value, Len(txt.Value) - 1)
        End If
 
    Case 6
        If Not IsDate(txt.Value & "2000") Then MsgBox "c'est pas bon!!! le mois ": txt.Value = Left(txt.Value, 3)
 
 
    Case 10
       
        If Not IsDate(txt.Value) Then txt.Value = Left(txt.Value, 6): mem = txt.Value: MsgBox "c 'est pas bon l'année!!": Exit Sub
     
        If Year(CDate(txt.Value)) <> Val(Right(txt.Value, 4)) Then MsgBox "c 'est pas bon l'année!!": txt.Value = Left(txt.Value, 6)
 
 
    End Select
 
    If Len(txt.Value) = 2 Or Len(txt.Value) = 5 Then txt.Value = txt.Value & IIf(Len(txt.Value) > Len(mem), "/", "")
 
    mem = txt.Value
End Sub

si tu comprends pas quelque chose n'hésite pas

patricktoulon · 25 Juin 2018

le chat merci pour la balise code

cathodique · 26 Juin 2018

patricktoulon à dit:
le minou bonjour
@cathodique

re
allez j'ai repris ton idée de msgbox
a une différence près c'est que la mienne peut valider les deux formats "31/12/xxxx ou 12/31/xxxx
bien entendu elle gère les années bissextiles par les 2 test isdate et year(text.value)<> du val(right(txt.value,4)) POUR LE CASE 10!!!
si tu ne comprends pas quelque chose n'hésite pas

Bonjour,
Merci beaucoup. Je n'ai pas encore testé. Cependant, étant en France la gestion des dates (m'embrouillent jusqu'à ce jour les méninges) Anglo-saxonnes me dérangent. J'aurais préféré que les cas comme 12/30/xxxx soient rejetés.

Encore merci pour ta gentillesse.
Bonne journée.

@Lone-wolf : Merci d'être revenu à la version initiale, je préfère le Sylvestre qu'au guerrier ou justicier imaginaire.

JM27 · 26 Juin 2018

bonjour à tous
@ Cathodique
je suis l'auteur du code que tu utilises .
tu en as enlevé une partie ce qui peut poser pb.
il est possible qu'il reste des "erreurs"

cathodique · 26 Juin 2018

JM27 à dit:
bonjour à tous
@ Cathodique
je suis l'auteur du code que tu utilises .
tu en as enlevé une partie ce qui peut poser pb.
il est possible qu'il reste des "erreurs"

Bonjour,
@JM27 : Sincèrement, je ne me souviens plus qui en est l'auteur. Je n'ai jamais revendiqué en être l'auteur.
J'étais membre d'un autre forum que j'ai quitté depuis pas mal de temps. Donc, je ne me souviens pas non plus sur quel forum j'ai eu ce code.
Je suis vraiment content de mettre un nom à ce bout de code. Si, il est vraiment de toi, tout est à ton honneur.
C'est un code que je garde depuis mais que je n'utilise plus car je préfère utiliser un calendrier autonome (je dois retrouver celui qui m'a aidé à l'adapter à mes besoins). Dorénavant, ton code restera chez-moi ainsi, si ça te conviens (mise à part la date à me communiquer, merci).

VB:

'---------------------------------------------------------------------------------------
' Module  : UserForm1
' DateTime  : 26/06/2018 15:46
' Author  : JM27
' Purpose  : Routine de validation de date à la saisie dans Textbox
'---------------------------------------------------------------------------------------
Option Explicit
Sub ValidationDate(TextBox1 As Object, Valide As Boolean)
Dim reponse As Variant
Dim LaDate As String
'
2 Select Case Len(TextBox1.Value)
    Case 1
        If CLng(TextBox1.Value) > 3 Then
            reponse = MsgBox("Le jour ne peut pas commencer par " & TextBox1.Value, vbOKOnly, "Erreur de saisie")
            TextBox1.Value = ""
            Exit Sub
        End If
    Case 2
        If CLng(TextBox1.Value) > 31 Then
            reponse = MsgBox("Le mois ne peut avoir plus de 31 jours", vbOKOnly, "Erreur de saisie")
            TextBox1.Value = Left(TextBox1.Value, 1)
            Exit Sub
        Else
            TextBox1.Value = TextBox1.Value & "/"
        End If
    Case 4
        If Right(TextBox1.Value, 1) > 1 Then
            reponse = MsgBox("L'année ne peut avoir plus de 12 mois", vbOKOnly, "Erreur de saisie")
            TextBox1.Value = Left(TextBox1.Value, 3)
            Exit Sub
        End If
    Case 5
        If CLng(Right(TextBox1.Value, 2)) > 12 Then
            reponse = MsgBox("L'année ne peut avoir plus de 12 mois", vbOKOnly, "Erreur de saisie")
            TextBox1.Value = Left(TextBox1.Value, 4)
            Exit Sub
        Else
            TextBox1.Value = TextBox1.Value & "/"
        End If
    Case 8
    LaDate = Left(TextBox1.Value, 6) & "20" & Right(TextBox1.Value, 2)
    If Not IsDate(LaDate) Then
        reponse = MsgBox("Le " & TextBox1.Value & " n'existe pas ", vbOKOnly, "Erreur de saisie")
        TextBox1.Value = ""
        Exit Sub
    End If
   
    Valide = True
End Select
End Sub

@+

JM27 · 26 Juin 2018

Bonsoir
tu ne peux pas le savoir. (pour l'auteur) ,je l'ai écris sous un autre pseudo
regarde le code du fichier que j'ai posté.
tu constateras qu'il y a des différences

patricktoulon · 26 Juin 2018

bonjour jm27
j'ai télécharge ton fichier et il me bloque a 2020 je ne peux pas mettre une autre année
et a en voir le code en supposant que je puisse taper une autre année il fait la même erreur

a savoir je le répète que isdate pour les années bissextiles avec le mois de février va te donner bon alors que non
tout simplement parce que isdate va interpréter autrement
et pour s'en rendre compte et savoir comment il va interpréter la date par exemple 29/02/0009

il suffit soit de faire
msgbox year("29/02/0009")
ou encore plus radicale
msgbox dateserial(0009,02,29)

et c'est la surprise surprise
donc je le redis si il n'y a pas ce double control (isdate/year() ou dateserial) tout code sans pourra dans certains cas donner des résultats surprenants

JM27 · 26 Juin 2018

Bonsoir
as tu testé tes dates qui pose pb avec mon fichier
Précise moi SVP les dates qui n'en sont pas merci
as tu bien tapé pour l'année uniquement les deux derniers chiffres ( c'est surement cela ton pb)
Pour info
les années supérieures à 50 et jusqu'a 99 donne 19 ème siècle
pour celle inférieure à 50 donne 20 ème siècle.
A adapter dans les userform en fonction de ce que l'on souhaite comme réponse

JM27 · 26 Juin 2018

Bonsoir
on peut aussi si l'on à plusieurs textbox date dans un userform avec des siècle différents transférer le siècle au moment de l'appel de la procédure de contrôle de la date

ne pas oublier de déclarer la variable Siècle si option explicit dans la procédure de l'userform
par exemple :

Code:

Private Sub TxtDateNaissance_Change()
Dim Validite As Boolean
Siècle = 19
Call ValidationDate(UserFormPVI.TxtDateNaissance, DateMin, DateMax, Siècle, Validite)
If Validite = True Then
    TxtDateNaissance = LaDate
End If
End Sub
' --------------- N'autorise que la saisie de chiffres
Private Sub TxtDateNaissance_KeyPress(ByVal Touche As MSForms.ReturnInteger)
    If InStr("0123456789", Chr(Touche)) = 0 Then Touche = 0
End Sub

et dans la procédure de contrôle

Code:

Option Explicit
Public LaDate As String

Public DateMin As Date, DateMax As Date
' =============== Routine de validation de date à la saisie dans Textbox ============================================
'
Sub ValidationDate(TextBox As Object, DateMini As Date, DateMaxi As Date, Siècle As Byte, Valide As Boolean)
Dim Reponse As Variant

'
2 Select Case Len(TextBox.Value)
    Case 1
        If CLng(TextBox.Value) > 3 Then
            Reponse = MsgBox("Le jour ne peut pas commencer par " & TextBox.Value, vbOKOnly, "Erreur de saisie")
            TextBox.Value = ""
            Exit Sub
        End If
    Case 2
        If CLng(TextBox.Value) > 31 Then
            Reponse = MsgBox("Le mois ne peut avoir plus de 31 jours", vbOKOnly, "Erreur de saisie")
            TextBox.Value = Left(TextBox.Value, 1)
            Exit Sub
        Else
            TextBox.Value = TextBox.Value & "/"
        End If
    Case 4
        If Right(TextBox.Value, 1) > 1 Then
            Reponse = MsgBox("L'année ne peut avoir plus de 12 mois", vbOKOnly, "Erreur de saisie")
            TextBox.Value = Left(TextBox.Value, 3)
            Exit Sub
        End If
    Case 5
        If CLng(Right(TextBox.Value, 2)) > 12 Then
            Reponse = MsgBox("L'année ne peut avoir plus de 12 mois", vbOKOnly, "Erreur de saisie")
            TextBox.Value = Left(TextBox.Value, 4)
            Exit Sub
        Else
            TextBox.Value = TextBox.Value & "/"
        End If
    Case 8
   
    LaDate = Left(TextBox.Value, 6) & Siècle & Right(TextBox.Value, 2)
   ' LaDate = Left(TextBox.Value, 6) & "20" & Right(TextBox.Value, 2)
    If Not IsDate(LaDate) Then
        Reponse = MsgBox("Le " & TextBox.Value & " n'existe pas ", vbOKOnly, "Erreur de saisie")
        TextBox.Value = ""
        Exit Sub
    End If
    If CDate(LaDate) < DateMini Then
        Reponse = MsgBox("La date doit être postérieure au " & DateMini & " et au format jj/mm/aa ", vbOKOnly, "Erreur de saisie")
        TextBox.Value = ""
        Exit Sub
    End If
    If CDate(LaDate) > DateMaxi Then
        Reponse = MsgBox("La date doit être antérieure au " & DateMaxi, vbOKOnly, "Erreur de saisie")
        TextBox.Value = ""
        Exit Sub
    End If
    Valide = True
   
End Select
End Sub

patricktoulon · 26 Juin 2018

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

alors c'est pire c'est un datebox qui ne peut aller en dessous de 2000 c'est impensable

d'autant plus fait le test tu verra
tape 29 puis 02 puis 00 tu aurra 29/02/2000 OK
maintenant resélectionne le 29 et remplace par 30 surprise y a plus de control de validité
d'autant plus que des que tu a un slash il es impossible de revenir avec la touche back
et tu en conviendra que niveau ergonomie c'est pas top (obligé de reprendre la souris selectionné >>supprimer)
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

job75 · 26 Juin 2018

Bonsoir,

JM27 à dit:
Pour info
les années supérieures à 50 et jusqu'a 99 donne 19 ème siècle
pour celle inférieure à 50 donne 20 ème siècle.

Pour info... Augmenter de un : 20ème et 21ème siècle.

A+

transformer un textbox en Datebox

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Lone-wolf

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

JM27

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

JM27

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

JM27

XLDnaute Barbatruc

Pièces jointes

JM27

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires