aurelio.ewane
XLDnaute Occasionnel
Bonjour a tous et merci pour tous ce que vous faites pour nous.
Mon problème est le suivant j'ai une série de Combobox sur lesquels je voudrais créer une fonction qui permettra de saisir une Date.
je voudrais que lors de la saisie que cela me permettes de m'aider dans le genre 12/12/2000
j'ai trouver un code que Jai essayer de modifier
mais j'ai de temps en temps des erreurs c'est pourquoi j'ai mis le On error resume next mais de temps en temps ca ne fonctionne plus
quelqu'un pourrait t'il m'aider a l'adapter car les utilisateurs finals de ce classeurs ne connaissent rien sur Excel cest pourquoi je voudrais que dans les combobox des dates que ca puisses les aider ainsi..
merci de votre aide
Cordialement
ci joint mon code
Public Function ComBoboxDate(ByVal tdat As Object, ByVal KeyCode As MSForms.ReturnInteger, Optional mask As String = "dd/mm/yyyy", Optional charMASK As String = "_")
'MsgBox KeyCode
Dim txt$, X&, plus&, longg&, sep$, mask2$
On Error Resume Next
'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
KeyCode = 0
Else
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
End If
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
If tdat = "" Or X = 0 Then
Else
tdat.SelStart = X - 1 'touche fleche gauche
End If
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
Mon problème est le suivant j'ai une série de Combobox sur lesquels je voudrais créer une fonction qui permettra de saisir une Date.
je voudrais que lors de la saisie que cela me permettes de m'aider dans le genre 12/12/2000
j'ai trouver un code que Jai essayer de modifier
mais j'ai de temps en temps des erreurs c'est pourquoi j'ai mis le On error resume next mais de temps en temps ca ne fonctionne plus
quelqu'un pourrait t'il m'aider a l'adapter car les utilisateurs finals de ce classeurs ne connaissent rien sur Excel cest pourquoi je voudrais que dans les combobox des dates que ca puisses les aider ainsi..
merci de votre aide
Cordialement
ci joint mon code
Public Function ComBoboxDate(ByVal tdat As Object, ByVal KeyCode As MSForms.ReturnInteger, Optional mask As String = "dd/mm/yyyy", Optional charMASK As String = "_")
'MsgBox KeyCode
Dim txt$, X&, plus&, longg&, sep$, mask2$
On Error Resume Next
'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
KeyCode = 0
Else
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
End If
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
If tdat = "" Or X = 0 Then
Else
tdat.SelStart = X - 1 'touche fleche gauche
End If
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