Màscara Fecha

31/10/2007 - 02:21 por Beneco | Informe spam
Muy buenas a todos de ante mano mil gracias por su valiosa ayuda:
En un Userform con 2 TextBox, TextBox1 para ingresar la fecha de nacimiento
y Textbox 2 para el resultado con el sgte còdigo:
- En el TextBox1:
On Error GoTo Fin
If KeyCode = vbKeyReturn Then TextBox1 = DateDiff("yyyy",
CLng(CDate(TextBox2)), Date)
Fin:

Para la màscar de entrada al estilo de Acces tengo la sgte funciòn:
Function Mascara_Fecha(ByRef TextB As MSForms.TextBox, _
ByRef b_Borrar As Boolean)
Dim n As Byte, nl As Byte, lt As String, max As Byte
With TextB
If .Text = "" Then b_Borrar = False: Exit Function
nl = Len(.Text): lt = Mid(.Text, nl, 1)
Select Case nl
Case Is = 1
If Not IsNumeric(lt) Or Val(lt) > 3 Then .Text = ""
Case Is = 2, Is = 5
If nl = 2 Then max = 31 Else max = 12
If Not IsNumeric(lt) Or _
(Mid(.Text, nl - 1, 1) & lt) > max Or _
Val(Mid(.Text, nl - 1, 1) & lt) < 1 Then
.Text = Left(.Text, nl - 1)
Else
If nl = 5 And Not IsDate(.Text & "/00") Then _
.Text = Left(.Text, nl - 1) Else _
.Text = .Text & "/"
End If
Case Is = 3, Is = 6
If b_Borrar Then .Text = Left(.Text, nl - 2)
Case Is = 4
If Not IsNumeric(lt) Or _
Val(lt) > 1 Then .Text = Left(.Text, nl - 1)
Case Is = 8
If Not IsNumeric(lt) Or (Left(.Text, 2) = _
"29" And Mid(.Text, 4, 2) = "02" And _
Val(Right(.Text, 2)) Mod 4 > 0) Then _
.Text = Left(.Text, 7)
Case Is > 8
.Text = Left(.Text, 8)
Case Else
If Not IsNumeric(lt) Then .Text = Left(.Text, nl - 1)
End Select
End With
b_Borrar = False
End Function

En el TextBox1:
Private Sub TextBox1_Change()
Dim Borrar As Boolean
Mascara_Fecha TextBox1, Borrar
End Sub


Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
If KeyCode = vbKeyBack Then Borrar = True
End Sub

Ahora bien todo èsto funciona perfectamente el problema es cuando la fecha
de nacimiento es menor a 1929 me arroja error.

Intento modificar la fecha en la configuraciòn regional pero es imposible ya
que èsta opciòn està descativada.

S@lu2..









Beneco

Preguntas similare

Leer las respuestas

#6 Ivan
02/11/2007 - 03:29 | Informe spam
hola, citandome a mi mismo (HM incluido)=>

creo que lo ideal seria volver al comentaario de Hector: => '(prueba
indicando los 4 digitos) -?- '







si quieres prueba esta modificacion:


Function Mascara_Fecha(ByRef TextB As MSForms.TextBox, _
ByRef b_Borrar As Boolean)
Dim n As Byte, nl As Byte, lt As String, max As Byte
With TextB
If .Text = "" Then b_Borrar = False: Exit Function
nl = Len(.Text): lt = Mid(.Text, nl, 1)
Select Case nl
Case Is = 1
If Not IsNumeric(lt) Or Val(lt) > 3 Then .Text = ""
Case Is = 2, Is = 5
If nl = 2 Then max = 31 Else max = 12
If Not IsNumeric(lt) Or _
(Mid(.Text, nl - 1, 1) & lt) > max Or _
Val(Mid(.Text, nl - 1, 1) & lt) < 1 Then
.Text = Left(.Text, nl - 1)
Else
If nl = 5 And Not IsDate(.Text & "/00") Then _
.Text = Left(.Text, nl - 1) Else _
.Text = .Text & "/"
End If
Case Is = 3, Is = 6
If b_Borrar Then .Text = Left(.Text, nl - 2)
Case Is = 4
If Not IsNumeric(lt) Or _
Val(lt) > 1 Then .Text = Left(.Text, nl - 1)
Case Is = 10
If Not IsNumeric(lt) Or (Left(.Text, 2) = _
"29" And Mid(.Text, 4, 2) = "02" And _
Val(Right(.Text, 2)) Mod 4 > 0) Then _
.Text = Left(.Text, 9)
Case Is > 10
.Text = Left(.Text, 10)
Case Else
If Not IsNumeric(lt) Then .Text = Left(.Text, nl - 1)
End Select
End With
b_Borrar = False
End Function

en cuanto a Borrar ...

un saludo
Ivan
Respuesta Responder a este mensaje
#7 Bennet
05/11/2007 - 03:03 | Informe spam
"Ivan" escribió:

hola,

solo un comentario, aparte de la consulta [respecto a esta creo que el tema va por donde indica Hector: año de 2 o 4
cifras (otro detalle no contemplado en la macro...) pues los de 2 cifras, si no recuerdo mal empiezan a contar a partir
de 1929 ( o 30 no estoy seguro) hasta el 2028 ( o 29)]:

=>>la variable Borrar deberias sacarla del evento Change y declararla a nivel de modulo del formulario

un saludo
Ivan





Muy buenas seguì al pie de la letra ambas indicaciones los cuales me fueron
totalmente ùtiles.
De nuevo mil gracias...


email Siga el debate Respuesta Responder a este mensaje
Ads by Google
Help Hacer una pregunta AnteriorRespuesta Tengo una respuesta
Search Busqueda sugerida