Resumen Validación y formateo de fechas

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).
---------------------------------------------------------------------------------------------------




Resumen Resumen

Visual Basic Página de Visual Basic

Página principal Página principal

www.jrubi.com