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

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

cathodique · 25 Juin 2018

Bonjour PatrickToulon

,

Personnellement, je suis heureux et ravi que tu fasses partie de notre communauté.
Merci beaucoup de partager avec nous tes compétences.
En effet, je faisais partie de l'autre communauté que j'ai quitté sans regret vu qu'elle a été polluée de "grosses têtes" à un certain moment.
Maintenant, je ne sais pas car je me suis désinscrit.
Cependant, j'avoue y avoir rencontré des gens merveilleux tels que toi et Mercatog, ainsi que d'autres.
Sincèrement, Merci de faire partie notre famille.

ChTi160 · 25 Juin 2018

Bonjour patricktoulon
Bonjour le fil ,le Forum
Patrick , j'ai tenté de tester ton fichier , mais je n'obtiens rien il faut savoir que j'utilise un portable (W10 ,2010) ,sans pavé numérique .
j'ai donc enclenché la touche Shift ou Majuscule ,pour obtenir les Chiffres , mais je n'obtiens aucun retour dans les textBox ;
Peux tu me dire ce qu'il faut que je fasse .
Merci par avance
Amicalement
jean marie

Simply · 25 Juin 2018

30/02/2018 ou 02/30/2018
Il ne vérifie pas l'existence de la date.

job75 · 25 Juin 2018

Bonjour à tous,

Proposer un masque de saisie pour les dates c'est prendre les gens pour des imbéciles.

Les solutions les plus simples sont souvent les meilleures.

A+

patricktoulon · 25 Juin 2018

cathodique à dit:
Bonjour PatrickToulon,

Personnellement, je suis heureux et ravi que tu fasses partie de notre communauté.
Merci beaucoup de partager avec nous tes compétences.
En effet, je faisais partie de l'autre communauté que j'ai quitté sans regret vu qu'elle a été polluée de "grosses têtes" à un certain moment.
Maintenant, je ne sais pas car je me suis désinscrit.
Cependant, j'avoue y avoir rencontré des gens merveilleux tels que toi et Mercatog, ainsi que d'autres.
Sincèrement, Merci de faire partie notre famille.

bonjour cathodique et merci ,oui c'est exactement ce qui se passe tu a tout compris

patricktoulon · 25 Juin 2018

job75 à dit:
Bonjour à tous,

Proposer un masque de saisie pour les dates c'est prendre les gens pour des imbéciles.

Les solutions les plus simples sont souvent les meilleures.

A+

Job75 bonjour , oui un test a la fin est on ne peut plus simple mais ca n'a rien a voir avec ce qui est proposé ici je fait le même test a la fin

patricktoulon · 25 Juin 2018

Simply à dit:
30/02/2018 ou 02/30/2018
Il ne vérifie pas l'existence de la date.

Simply c'est très étonnant ce que tu me dit je vais tester voir il est fort possible que j'ai zappé quelque chose mais ça m’entonnerais beaucoup puisque il n'est déjà pas possible d’écrire 30/02/____ ou 02/30/____mais dans le doute je vais vérifier merci des retours ca me permet de corriger si il y a lieu

patricktoulon · 25 Juin 2018

ChTi160 à dit:
Bonjour patricktoulon
Bonjour le fil ,le Forum
Patrick , j'ai tenté de tester ton fichier , mais je n'obtiens rien il faut savoir que j'utilise un portable (W10 ,2010) ,sans pavé numérique .
j'ai donc enclenché la touche Shift ou Majuscule ,pour obtenir les Chiffres , mais je n'obtiens aucun retour dans les textBox ;
Peux tu me dire ce qu'il faut que je fasse .
Merci par avance
Amicalement
jean marie

a oui la ça m’intéresse, il est fort possible que utilisant le pavé numérique par shift (haut du clavier)la gestion du Keycode soit différente j'avoue je n'y ai pas pensé
qu'est ce que le msgbox donne pour 1 et 9 du haut de clavier avec ca
'------------------------------------------------------------------------------------------------------------------------
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
MsgBox KeyCode
End Sub
'-------------------------------------------------------------------------------------------------------------------------

merci pour ce retour

patricktoulon · 25 Juin 2018

ChTi160 à dit:
Bonjour patricktoulon
Bonjour le fil ,le Forum
Patrick , j'ai tenté de tester ton fichier , mais je n'obtiens rien il faut savoir que j'utilise un portable (W10 ,2010) ,sans pavé numérique .
j'ai donc enclenché la touche Shift ou Majuscule ,pour obtenir les Chiffres , mais je n'obtiens aucun retour dans les textBox ;
Peux tu me dire ce qu'il faut que je fasse .
Merci par avance
Amicalement
jean marie

bonjour ChTi60 :a tu mis le masque au moins ? "__/__/____" dans le textbox en mode VBE ou dans la propriété text
sinon sans bien évidement ça ne peut pas fonctionner

ChTi160 · 25 Juin 2018

Re
C est initialise a l ouverture du userform et du classeur sur la feuille (rien modifie lol)
Merci du retour
Bonne fin de soiree
Je teste la suggestion du post #9
Desque possible

cathodique · 25 Juin 2018

Re,

Moi j'utilise ce code pour vérifier la validité des dates.
J'espère que ça sera utile.

VB:

' --------------- N'autorise que la saisie de chiffres

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()
Dim Validite As Boolean
Call ValidationDate(UserForm1.TextBox1, Validite)       'UserForm1
End Sub

' =============== Routine de validation de date à la saisie dans Textbox ============
'================              Dans un module standard                   ============
'
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

@+++

patricktoulon · 25 Juin 2018

RE
bon après toute vos remarques

j'ai rendu le role de la touche BACK plus fluide son comportement est identique a son origine tout en gardant le masque
j'ai rendu son role a la touche SUPPR suppression possible de la partie 1,2,3 ou même les 3 de la date d'un coup tout en gardant le masque
j'ai aussi ajouté la prise en charge des touche chiffre en haut du clavier sauf qu'il n'est même pas nécessaire de mettre en majuscule
j'ai amélioré le test isdate pour l'année (29/02/XXXX)(année bissextile) malheureusement isdate n’était pas suffisant!!

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

patricktoulon · 25 Juin 2018

cathodique à dit:

Re,

Moi j'utilise ce code pour vérifier la validité des dates.
J'espère que ça sera utile.

VB:

' --------------- N'autorise que la saisie de chiffres

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()
Dim Validite As Boolean
Call ValidationDate(UserForm1.TextBox1, Validite)       'UserForm1
End Sub

' =============== Routine de validation de date à la saisie dans Textbox ============
'================              Dans un module standard                   ============
'
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

@+++

patricktoulon · 25 Juin 2018

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

Effectuez une recherche sur Excel Downloads...

transformer un textbox en Datebox

patricktoulon

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Simply

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums