Collection textbox formatés(patricktoulon)Un  DateBox avec masque de saisie

Collection textbox formatés(patricktoulon)Un DateBox avec masque de saisie V2.0

Bonjour a tous
je vous propose ma fonction qui transforme un TextBox en Date Box pour les 3 formats principaux

il vous est impossible de taper une date erronée
la gestion d'erreur re sélectionne le segment de la chaîne tapée qui est une erreur accompagné d'un beep

vous avez la gestion de la touche Back , Suppr , Fleche Droite , Fleche gauche
le masque de saisie est automatique

je laisse le case 9 et 13 (tab et enter )a votre grès d'utilisation


la fonction dans le userform ou module standard

VB:
Option Explicit
Public Function control_keydown(tdat As Object, KeyCode, Optional mask As String = "dd/mm/yyyy", Optional charMASK As String = "_")
'MsgBox KeyCode
    Dim txt$, X&, plus&, longg&, sep$, mask2$
    'construction du masque de saisie(mask2) en fonction de la chaine de format de date injectée
    mask2 = Replace(Replace(Replace(mask, "d", charMASK), "m", charMASK), "y", charMASK)
    sep = Left(Replace(mask2, charMASK, ""), 1) 'determine le caractere de separation
    If tdat = "" Then tdat = mask2    'si textbox vide alors = mask2
    txt = tdat.Value: If txt = mask2 Then tdat.SelStart = 0: tdat = ""
    X = tdat.SelStart: longg = tdat.SelLength: If longg = 0 Then longg = 1
    If KeyCode = 8 And longg > 1 Then KeyCode = 46
    Select Case KeyCode
    Case 96 To 105
        If X = 10 Then KeyCode = 0: Exit Function
        If Mid(mask2, X + 1, 1) = sep Then X = X + 1
        Mid(txt, X + 1, longg) = Mid(mask2, X + 1, longg): tdat = txt: plus = IIf(KeyCode < 96, 32, -48):    'reformate si plus de 1 caractere selectionné
        Mid(txt, X + 1, 1) = Chr(KeyCode + plus): tdat = txt: tdat.SelStart = X + 1: KeyCode = 0
        If Mid(tdat, X + 2, 1) = sep Then tdat.SelStart = X + 2

        'control de validité de la date tapée a tout moment
        Dim Pos1&, Pos2&, Part1$, Part2$, Part3$, PosX&
        Select Case True    'determine les segment jours/mois/année  et les positions selstart SELON le format injecté
        Case Left(mask, 2) = "yy": Part2 = Mid(tdat, 6, 2): Part1 = Mid(tdat, 9, 2): Part3 = Mid(tdat, 1, 4): Pos1 = 8: Pos2 = 5: PosX = 8
        Case Left(mask, 2) = "mm": Part2 = Mid(tdat, 1, 2): Part1 = Mid(tdat, 4, 2): Part3 = Mid(tdat, 7, 4): Pos2 = 0: Pos1 = 3: PosX = 3
        Case Left(mask, 2) = "dd": Part1 = Mid(tdat, 1, 2): Part2 = Mid(tdat, 4, 2): Part3 = Mid(tdat, 7, 4): Pos1 = 0: Pos2 = 3: PosX = 3
        End Select

        'on ne peut depasser 31 pour les jours et 12 pour le mois quelque soit le format
        If Val(Part1) > 31 Or Val(Left(Part1, 1)) > 3 Or Part1 = "00" Then tdat.SelStart = Pos1: tdat.SelLength = 2: Beep: Exit Function
        If Val(Part2) > 12 Or Val(Left(Part2, 1)) > 1 Or Part2 = "00" Then tdat.SelStart = Pos2: tdat.SelLength = 2: Beep: Exit Function

        'quand jour et mois sont rempli on teste avec l'annéee 2000(année bissextile pour fevrier)et 30 ou 31 pour les autres mois
        If IsDate(Part1 & "/" & Part2) Then If Not IsDate(Part1 & "/" & Part2 & "/2000") Then tdat.SelStart = PosX: tdat.SelLength = 2: Beep

        If Not IsDate(tdat) And InStr(tdat, charMASK) = 0 Then    'si plus de caracteres mask on teste la date complete
            tdat.SelStart = InStrRev(tdat.Text, sep): tdat.SelLength = 4: Beep: Exit Function
        Else
            'pour pallier a l'erreur de isdate pour les année inferieur a 100 pour fevrier
            If IsDate(tdat) Then If Year(CDate(tdat)) <> Val(Part3) Then tdat.SelStart = InStrRev(tdat.Text, sep): tdat.SelLength = 4: Beep
        End If

    Case 8    'touche BACK (Retour en arrière)
        If X <> 0 Then Mid(txt, X, longg + 1) = Mid(mask2, X, longg + 1)
        tdat = txt: tdat.SelStart = X - 1: KeyCode = 0
        If tdat = mask2 Then tdat = ""
        If Mid(txt, X - IIf(X > 1, 1, 0), 1) = sep Then tdat.SelStart = X - 2
    Case 46 'touche Suppr(supprimer)
    Mid(txt, X + 1, longg) = Mid(mask2, X + 1, longg): KeyCode = 0: tdat = txt: tdat.SelStart = X    'touche Suppr

    Case 37: tdat.SelStart = X - 1    'touche fleche gauche
    Case 39: tdat.SelStart = X + 1    'touche fleche droite

    Case 13 Or 9    ' ce que l'on veux c'est la sortie

    Case Else: KeyCode = 0    'touche les autres touches sont exclues
    End Select

End Function

tout les arguments sont optional sauf bien entendu le textbox et keycode
de ce fait par défaut le format sera "dd/mm/yyyy" et le masque sera "__/__/____"

comment on s'en sert ?
apel de la fonction
control_keydown [TextBox] , [KeyCode] , [format de date] , [caractère de masque de saisie]


exemple
Code:
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_keydown TextBox1, KeyCode, "yyyy-mm-dd", "_"
End Sub

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_keydown TextBox2, KeyCode, "mm/dd/yyyy", "_"
End Sub

Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_keydown TextBox3, KeyCode, "dd/mm/yyyy", "_"
End Sub

Private Sub TextBox4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_keydown TextBox4, KeyCode 'argument omis donc par defaut"dd/mm/yyyy" mask"__/__/____"
End Sub
Private Sub TextBox5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_keydown TextBox5, KeyCode, "dd mm yyyy"
End Sub
Auteur
patricktoulon
Version
2.0

Derniers avis

Excellent
Bonjour,
Je cherchais justement ce code pour mon UserForm
Merci
Amicalement
Bruno