patricktoulon

[CENTER][B]UN DATEBOX MULTI FORMAT DYNAMIQUE AVEC MASQUE DE SAISIE
EPISODE 1[/B][/CENTER]

bonjour a tous
c'est un exercice qui a été compliqué au depart et nombreux ont été les essais qui ont pu sortir de ma tete et bien mal pensés

[B]cahier des charges pour ce projet
[/B]
[LIST=1][*][B]imposer et avoir le choix [/B]un format de date dans un textbox[*]avoir un [B]masque [/B]de saisie en l'occurence("__/__/____")[*][B]restreindre[/B] l'utilisation des touches ( pavé numerique (haut du clavier ou pavé a droite du clavier)) ,la touche back , suppr, fleche(droite et gauche)[*][B]avertir et annuler[/B] la frappe quand une date (completement rédigée ou pas) est éronée[*][B]mise en evidence [/B]de l'erreur en selectionnant la partie de la date ou partie de date tapée en erreur[*][B]utilisation minimum [/B]de variable globale[B] voir pas du tout [/B](economie memoire)[*][B]pouvoir naviguer [/B]entre les parties de la date avec les touche de navigation(TAB et fleches)[*][B]revenir en arriere[/B] avec la [B]touche back [/B]avec remise en place de la partie homologue du mask[*][B]transportabilité [/B][*]que ce ne soit pas une [B]usine a gaz [/B][*]j'ai mis en place le masque des la premiere touche tapée quelle quel soit ( vous n'avez donc pas a le mettre en mode edition dans VBE)[/LIST]

bref rendre impossible de taper une date eronnée sans en etre averti

et cela avec un seul evenement textbox (dans cet exercice j'ai choisi le [B]keydown)[/B]

il y a divers exemple ici et la je vous laisse le soins d'en apprecier leur valeur en fonction du meme cahier des charges


pour que ce code puisse servir a plusieur textboxs sur un meme [B]userform [/B]je l'ai fait dans une sub que l'on mettra dans un module standard

rien ne vous empeche cela dit d'en faire une private sub et la mettre dans le [B]module du userform[/B]

j'ai aéré le code pour plus d'aisance dans la lisibilité du code

voila donc la sub
[CODE=vba]Option Explicit
'Date:01/10/2018
'auteur:-------------------------patricktoulon sur developpez.com et excel download
'projet:-------------------------datebox multi format avec mask de saisie dynamique au format injecté dans l'appel
'version:------------------------3.2
'format de date accepté:---------"dd/mm/yyyy" : "mm/dd/yyyy" : "yyyy/mm/dd"
'touche clavier utilisable:------TAB :ENTER :FLECHES (DROITE et GAUCHE) : pavé numerique (HAUT et BAS)
'action 1:-----------------------positionnement automatique pendant la saisie
'action 2:-----------------------navigation dans les parties de la date(jour/mois/année)avec les touches TAB et fleches(droite et gauche)
'action 3:-----------------------retour et selection automatique en cas d'erreur dans la partie qui viend d'etre tapée
'modifications:le 07/10/2018-----ajout du Rollover sur les touches de navigation(ergonomie)
'modifications le 08/10/2018-----amélioration de la gestion des touches de navigation et de la touche back(ergonomie)(le next segment pris en compte au selstart+1)
'modifications le 08/10/2018-----ajout du test si le format injecté n'est pas accepté et de la sortie avec message
'modifications le 12/10/2018-----correction l'erreur non relevée du "00" mois et jour

Sub control_saisiex(txt, KeyCode, Optional Forme As String = "dd/mm/yyyy")
Dim t$, xL&, X&, M&, J&, A&, Ji&, Mi&, Ai&, finD&, ldate As Date, MasK$
'calcul des selstart autorisés pour le keycode 96 to 105 en fonction du format
Ji = InStr(1, Forme, "d"): Mi = InStr(1, Forme, "m"): Ai = InStr(1, Forme, "y")
'Création du mask en fonction du format injecté dans l'apel
If Ai = 7 Then finD = 6 Else finD = 8 'repere pour le next selstart avec les touches de navigation
Select Case Forme
Case "yyyy/mm/dd": MasK = "____/__/__": Case "dd/mm/yyyy", "mm/dd/yyyy": MasK = "__/__/____"
Case Else: MsgBox "le format demandé n'est pas accepté": KeyCode = 0: Exit Sub 'si un format injecté nest pas valide on sort
End Select
With txt
If .Value = "" Then .Value = MasK 'au cas ou le masque n'y serait pas au depart
t = .Value 'T prend la valeur du textbox
If TypeName(.Parent) = "UserForm" Then .ControlTipText = Forme ' bulle indiquant le format qui a été injecté
If t = MasK Then .SelStart = 0 ' on se positionne a gauche si pas de date(mask vierge)
X = .SelStart: xL = .SelLength 'on determine la position et le length de la selection
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 des touches du pavé numerique(haut et bas)
Case 96 To 105
Select Case X
Case Ji - 1 To Ji, Mi - 1 To Mi, Ai - 1 To Ai + 2
Mid$(t, X + 1, IIf(xL = 0, 1, xL)) = Chr(KeyCode - 48) & Mid$(MasK, X + 2): .Value = t: .SelStart = X + 1
Case Else: KeyCode = 0
End Select
If Mid$(t, X + 2, 1) = "/" Then .SelStart = X + 2
KeyCode = 0
'_______________________________________________________________________________________
'controle de la validité de la date ici
J = Val(Mid$(t, Ji, 2)): M = Val(Mid$(t, Mi, 2)): A = IIf(Mid$(t, Ai, 4) Like "*_*", 2000, Val(Mid$(t, Ai, 4))) 'récuperation du jour mois année en fonction de l'etat de la saisie
J = IIf(J = 0, 1, J): M = IIf(M = 0, 1, M): ldate = DateSerial(A, M, J): 'date théorique ou reele dynamique
If Day(ldate) <> J Or Month(ldate) <> M Or Year(ldate) <> A Or Val(Mid$(t, Ji, 1)) > 3 Or Val(Mid$(t, Mi, 1)) > 1 Or Mid$(t, Ji, 2) = "00" Or Mid$(t, Mi, 2) = "00" Then 'Condition d 'erreur globale
X = InStrRev(Mid$(t, 1, X), "/"): xL = IIf(X = Ai - 1, 4, 2): Mid(t, X + 1, xL) = Mid(MasK, X + 1, xL): .Value = t: .SelStart = X: .SelLength = xL: Beep 'repositionnement et annulation de la partie en erreur
End If
'_____________________________________________________________________________________________________
'Gestion de la Touche back(retours en arrière)
Case 8
If InStr(Mid$(t, 1, X), "/") > 0 Then X = InStrRev(Mid$(t, 1, InStrRev(Mid$(t, 1, X), "/") - IIf(Mid(t, X, 1) = "/", 1, 0)), "/") Else X = 0
KeyCode = 0: xL = IIf(X = Ai - 1, 4, 2): Mid$(t, X + 1, xL) = "____": .Value = t: .SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, xL)
'_____________________________________________________________________________________________________
'Gestion de la Touche suppr(supprimer)remplace la partie selectionnée par son homologue du masque
Case 46
xL = IIf(xL = 0, 1, xL): KeyCode = 0: Mid$(t, X + 1, xL) = Mid$(MasK, X + 1, xL): .Value = t: .SelStart = IIf(t = MasK, 0, X)

'_____________________________________________________________________________________________________
'gestion de la Touche fleche gauche deplacement vers la gauche et Rollover
Case 37
KeyCode = 0: X = InStrRev(t, "/", IIf(X = 1, 2, X - 1)): xL = IIf(X = Ai - 1, 4, 2):
.SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, xL)

'_____________________________________________________________________________________________________
'Gestion de la Touche fleche droite et la touche tab deplacement vers la droite et Rollover
Case 39, 9
If InStr(Mid$(t, X + 1), "/") > 0 Then X = X + InStr(1, Mid$(t, X + 1), "/") Else X = 0 'x=find si on veut pas que ca tourne
KeyCode = 0: .SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, IIf(X = Ai - 1, 4, 2))
Case 13
If InStr(txt.Value, "_") Then KeyCode = 0
'_____________________________________________________________________________________________________
'Gestion des autres touches
Case Else: KeyCode = 0
End Select
End With
End Sub
[/CODE]

et donc dans le userform OUpour un textbox dans un sheets on l'appelera comme suit avec l'evenement [B]keydown
exemple :
[/B][CODE=vba]Option Explicit
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox1, KeyCode, "yyyy/mm/dd"
End Sub
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox2, KeyCode, "dd/mm/yyyy"
End Sub
Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox3, KeyCode, "yyyy/mm/dd"
End Sub
Private Sub TextBox4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox4, KeyCode 'sans argument le format par defaut est francais
End Sub

[/CODE]

pour le cas ou avec la souris on clique sur un autre control et donc sortie du textbox en ayant pas une date correcte
on bloque la sortie avec le before update
mais ca reste a la charge du developpeur: en effet les possibilité en fonction de la sortie peuvent etre diverses et variée
le travaille ici a consisté uniquement a controler la saisie

mais bien que l'on sorte de mon projet qui est l'utilisation du keydown , il est interessant et utile de le proposer
un exemple selon pijaku :
[CODE=vba]Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = Not IsDate(TextBox1.Value)
End Sub
[/CODE]

et pour proteger le textbox contre la modification par vba

[CODE=vba]Private Sub TextBox1_Change()
If TextBox1 <> ActiveControl Then
If Not IsDate(TextBox1.Value) Then TextBox1.Value = "__/__/____"
End If
End Sub
[/CODE]


Merci pijaku pour les tests

un classeur en exemple en piece jointe