Hola:
Por si os son útiles aquí van las funciones que yo uso para la validación y
formateo de fechas introducidas en un TextBox:
Por supuesto, acepto cualquier sugerencia o mejora.
' Función propia para comprobar si una fecha es válida
' (En formato europeo)
Public Function IsFecha(ByVal sFecha As String) As Boolean
Dim bIsFecha As Boolean
Dim iDia As Integer
Dim iMes As Integer
Dim iAnyo As Integer
Dim s As String
Dim iMod4 As Integer
Dim iMod400 As Integer
Dim iMod100 As Integer
Dim iPos As Integer
Dim iPos2 As Integer
'<- Push Error
On Error GoTo SiError
'Push Error ->
bIsFecha = True
s = sFecha
' Sustituyo los '-' por '/'.
s = StrTrans(s, "-", "/")
' Ha de tener el mes el día y el año.
If NumCar(s, "/") <> 2 Then
bIsFecha = False
GoTo Salir
End If
iPos = InStr(s, "/")
iDia = Val(Mid$(s, 1, iPos - 1))
iPos2 = InStr(iPos + 1, s, "/")
iMes = Val(Mid$(s, iPos + 1, iPos2 - iPos - 1))
iAnyo = Val(Mid$(s, iPos2 + 1))
If iDia > 0 And iMes > 0 And iAnyo > 0 Then
If iMes <= 12 Then
If (iMes = 1 Or iMes = 3 Or iMes = 5 Or iMes = 7 Or iMes = 8 Or iMes = 10
Or iMes = 12) And iDia > 31 Then
bIsFecha = False
GoTo Salir
End If
If (iMes = 4 Or iMes = 6 Or iMes = 9 Or iMes = 11) And iDia > 30 Then
bIsFecha = False
GoTo Salir
End If
If iMes = 2 Then
iMod4 = iAnyo Mod 4
iMod400 = iAnyo Mod 400
iMod100 = iAnyo Mod 100
' Años no bisiestos los que no son divisibles por 4 o que siéndolo
' son divisibles por 100 y no lo son por 400.
If iMod4 <> 0 Or (iMod100 = 0 And iMod400 <> 0) Then
' No bisiestos
If iDia > 28 Then
bIsFecha = False
GoTo Salir
End If
Else ' Bisiestos
If iDia > 29 Then
bIsFecha = False
GoTo Salir
End If
End If
End If
End If
Else
bIsFecha = False
End If
'<- Pop Error
Salir:
oMyError.PopError
IsFecha = bIsFecha
Exit Function
'Pop Error ->
'<- Si Error
SiError:
oMyError.AccionError Err
Select Case oMyError.Accion
Case errAccionSalir
bIsFecha = False
GoTo Salir
Case errAccionResume
Resume
Case errAccionResumeNext
Resume Next
Case errAccionEnd
TerminaApp
End Select
'Si Error ->
End Function
--------------------
' Devuelve el nº de veces que aparece la cadena 'Busca' en 'Text'
Public Function NumCar(ByVal Text As String, ByVal Busca As String) As Integer
Dim i As Integer
Dim s As String
Dim iLen As Integer
Dim iNumCar As Integer
Dim iCar As Integer
'<- Push Error
On Error GoTo SiError
oMyError.PushError NameMod, "NumCar"
'Push Error ->
iLen = Len(Busca)
iNumCar = 0
For i = 1 To iLen
s = Mid$(Busca, i, 1)
iCar = InStr(Text, s)
Do Until iCar = 0
iNumCar = iNumCar + 1
iCar = InStr(iCar + 1, Text, s)
Loop
Next i
'<- Pop Error
Salir:
NumCar = iNumCar
oMyError.PopError
Exit Function
'Pop Error ->
'<- Si Error
SiError:
oMyError.AccionError Err
Select Case oMyError.Accion
Case errAccionSalir
iNumCar = 0
GoTo Salir
Case errAccionResume
Resume
Case errAccionResumeNext
Resume Next
Case errAccionEnd
TerminaApp
End Select
'Si Error ->
End Function
-----------------------
'Busca en sCadena la subcadena sCadOld y la sustituye por sCadNew
'Devolviendo la subcadena final
Public Function StrTrans(ByVal sCadena As String, ByVal sCadOld As String, ByVal
sCadNew As String) As String
Dim iPos As Integer, iNewPos As Integer
Dim sStrTrans As String
'<- Push Error
On Error GoTo SiError
oMyError.PushError NameMod, "StrTrans"
'Push Error ->
sStrTrans = sCadena
If sCadOld <> sCadNew And sCadOld <> "" Then
iNewPos = 1
iPos = InStr(1, sStrTrans, sCadOld)
Do Until iPos = 0
sStrTrans = Left$(sStrTrans, iPos - 1) + sCadNew + Mid$(sStrTrans, iPos +
Len(sCadOld), Len(sStrTrans))
iNewPos = iPos + Len(sCadNew)
iPos = InStr(iNewPos, sStrTrans, sCadOld)
Loop
End If
StrTrans = sStrTrans
'<- Pop Error
Salir:
oMyError.PopError
Exit Function
'Pop Error ->
'<- Si Error
SiError:
oMyError.AccionError Err
Select Case oMyError.Accion
Case errAccionSalir
sStrTrans = ""
GoTo Salir
Case errAccionResume
Resume
Case errAccionResumeNext
Resume Next
Case errAccionEnd
TerminaApp
End Select
'Si Error ->
End Function
-------------------------
' Formatea una fecha de la siguiente forma:
' Si sólo se introduce el día, se le añaden el mes y el año actual.
' y si sólo se introduce el día y el mes, se le añade el año actual.
' Por último, si el año tiene menos de 4 dígitos, se le añaden los
' dos primeros del año actual.
Public Function FmtFecha(ByVal sFecha As String) As String
Dim sFmtFecha As String
Dim s As String
Dim i As Integer
Dim sSep As String
'<- Push Error
On Error GoTo SiError
oMyError.PushError NameMod, "FmtFecha"
'Push Error ->
sFmtFecha = Trim$(sFecha)
' Se sustituye el "-" o la "/" por es símbolo establecido en el programa
' como separador de fechas
sSep = oMyApp.SepFechas
If sSep = "/" Then
sFmtFecha = StrTrans(sFmtFecha, "-", "/")
Else
sFmtFecha = StrTrans(sFmtFecha, "/", "-")
End If
i = InStr(sFmtFecha, sSep)
' Sólo se introdujo un número, el cual se tomará como el día.
If i = 0 Then
sFmtFecha = sFmtFecha & sSep
i = Len(sFmtFecha) ' Para que busque a partir de la posición de la barra.
End If
' Buscamos la segunda barra
i = InStr(i + 1, sFmtFecha, sSep)
' No se halló la segunda barra, entonces comprobar si se introdujo el mes
' o no.
If i = 0 Then
' No se introdujo el mes, añadir el actual
If Right$(sFmtFecha, 1) = sSep Then
sFmtFecha = sFmtFecha & Month(Date) & sSep
i = Len(sFmtFecha) ' Para que busque a partir de la posición de la barra.
Else
' No se introdujo el año: añadirle la barra
sFmtFecha = sFmtFecha & sSep
i = Len(sFmtFecha) ' Para que busque a partir de la posición de la barra.
End If
'Else ' Sí se introdujo una barra.
' Añadir el mes si no se introdujo
' If i = Len(sFmtFecha) Then
' sFmtFecha = sFmtFecha & Month(Date) & "/"
' i = Len(sFmtFecha) ' Para que busque a partir de la posición de la barra.
' Else
End If
' Si no se especificó el año
If i = Len(sFmtFecha) Then
sFmtFecha = sFmtFecha & Year(Date)
Else
' Comprobar el número de dígitos del año y añadir los que falten
s = Mid$(sFmtFecha, i + 1) ' Extraer los dígitos posteriores a la barra.
sFmtFecha = Left$(sFmtFecha, i) & FmtAnyo(s) 'Left$(Year(Date), 4 - Len(s)) &
s
End If
'<- Pop Error
Salir:
' Sólo hacemos el cambio si la fecha resultante es una fecha válida.
If IsFecha(sFmtFecha) Then
FmtFecha = sFmtFecha
Else
FmtFecha = sFecha
End If
oMyError.PopError
Exit Function
'Pop Error ->
'<- Si Error
SiError:
oMyError.AccionError Err
Select Case oMyError.Accion
Case errAccionSalir
sFmtFecha = sFecha
GoTo Salir
Case errAccionResume
Resume
Case errAccionResumeNext
Resume Next
Case errAccionEnd
TerminaApp
End Select
'Si Error ->
End Function
-------------------
' Convierte un número en un año de cuatro dígitos, añadiéndole los
' dígitos que le falten según sea < 60 o mayor.
Public Function FmtAnyo(ByVal sAnyo As String) As String
Dim sFmtAnyo As String
'<- Push Error
On Error GoTo SiError
oMyError.PushError NameMod, "FmtAnyo"
'Push Error ->
' Por defecto devolverá el valor recibido sin modificar
sFmtAnyo = sAnyo
' Comprobar el número de dígitos del año y añadir los que falten
If Len(sAnyo) < 4 Then
If CInt(sAnyo) < 60 Then
sFmtAnyo = Left$("2000", 4 - Len(sAnyo)) & sAnyo
Else
sFmtAnyo = Left$("1900", 4 - Len(sAnyo)) & sAnyo
End If
End If
FmtAnyo = sFmtAnyo
'<- Pop Error
Salir:
oMyError.PopError
Exit Function
'Pop Error ->
'<- Si Error
SiError:
oMyError.AccionError Err
Select Case oMyError.Accion
Case errAccionSalir
sFmtAnyo = ""
GoTo Salir
Case errAccionResume
Resume
Case errAccionResumeNext
Resume Next
Case errAccionEnd
TerminaApp
End Select
'Si Error ->
End Function
--
Mensaje enviado a la velocidad de 0.00001 bits /seg. a través de Tortu-Arrakis.
---------------------------------------------------------------------------------------------------
Ley de Murphy
La experiencia es una cosa que no tienes hasta después de haberla necesitado
E-Mail: Mailto:jatubio@arrakis.es (Juan Antonio Tubío)
Un saludo desde Córdoba (España).
---------------------------------------------------------------------------------------------------