Jabato Games: Funciones Avanzadas de fechas Asp y Visual Basic

He encontrado una página muy buena que tiene muchísimas funciones sobre fechas en lenguaje Visual Basic, VBScript, ASP (Para Asp habrá que modificar un par de cosillas, como quitar Optional y la declaración de las variables).

La página es http://www.mvp-access.es/emilio/Access/Fechas.asp#CambioHorarioVerano

Saludos.

Os copio dichas funciones:

'*******************************************************************************
'* confirma la validez de la fecha pasada como parametro, devolviendola si es
'* valida con formato cadena dd/mm/aa y si procede hh:mm:ss
'* también la devuelve en formato fecha si se pasa el parametro opcional, datFecha
'* la fecha a pasar tiene que tener como minimo un digito para día, otro para mes
'* otro para año y en caso de incluir hora, hora y minutos
'* uso If ValidarFecha(strFecha, datFecha) Then
'* ESH 05/02/03 19:15
'*******************************************************************************

Public Function ValidarFecha(strFecha As String, Optional datFecha) As Boolean
Dim intDia As Integer, _
 intMes As Integer, _
 intAño As Integer, _
  intHora As Integer, _
  intMinutos As Integer, _
  intSegundos As Integer, _
  byt1aBarra As Byte, _
  byt2aBarra As Byte, _
  bytEspacio As Byte, _
  byt1oDosPuntos As Byte, _
  byt2oDosPuntos As Byte

ValidarFecha = False

' si la fecha no tiene un minimo de 5 digitos aborto el proceso
If Len(strFecha) < 5 Then strFecha = "": Exit Function

' busco la posición de las barras de fecha
byt1aBarra = InStr(strFecha, "/")
byt2aBarra = InStrRev(strFecha, "/")

' busco la posición de los dos puntos de hora
bytEspacio = InStr(strFecha, " ")
byt1oDosPuntos = InStr(strFecha, ":")

intDia = Val(Left(strFecha, byt1aBarra - 1))
intMes = Val(Mid(strFecha, byt1aBarra + 1, byt2aBarra - byt1aBarra - 1))

If byt1oDosPuntos = 0 Then
   intAño = Val(Mid(strFecha, byt2aBarra + 1))
Else
   intAño = Val(Mid(strFecha, byt2aBarra + 1, bytEspacio - byt2aBarra - 1))
End If

' si el día o el mes están fuera de rango aborto el proceso
If intDia < 1 Or intDia > 31 Then strFecha = "": Exit Function
If intMes < 1 Or intMes > 12 Then strFecha = "": Exit Function

' si aparecen los dos puntos, es por que hay hora
If byt1oDosPuntos <> 0 Then
byt2oDosPuntos = InStrRev(strFecha, ":")

intHora = Val(Mid(strFecha, bytEspacio + 1, byt1oDosPuntos - bytEspacio - 1))

' según haya o no segundos
If byt2oDosPuntos = byt1oDosPuntos Then
   intMinutos = Val(Mid(strFecha, byt1oDosPuntos + 1))
   intSegundos = 0
 Else
   intMinutos = Val(Mid(strFecha, byt1oDosPuntos + 1, byt2oDosPuntos - byt1oDosPuntos - 1))
   intSegundos = Val(Mid(strFecha, byt2oDosPuntos + 1))
 End If   ' byt2oDosPuntos = byt1oDosPuntos

 If intHora > 23 Then strFecha = "": Exit Function
 If intMinutos > 59 Then strFecha = "": Exit Function
 If intSegundos > 59 Then strFecha = "": Exit Function
End If  ' byt1oDosPuntos <> 0

' reconstruyo la fecha y la devuelvo en formato cadena d/m/a o d/m/a h:m:s
If byt1oDosPuntos = 0 Then
 strFecha = CStr(format(DateSerial(intAño, intMes, intDia), "dd/mm/yy"))
Else
   strFecha = CStr(format(DateSerial(intAño, intMes, intDia) & " " & TimeSerial(intHora, _
                   intMinutos, intSegundos), "dd/mm/yy hh:nn:ss"))
End If   ' byt1oDosPuntos = 0

ValidarFecha = True

' la devuelvo en el formato correspondiente
datFecha = CDate(strFecha)

End Function  ' ValidarFecha

'*******************************************************************************
'* Devuelve el número de días habiles comprendidos entre dos fechas
'* NO contempla días festivos
'* uso: DiasHabiles ("01/01/03", "01/02/03")
'* ESH 15/05/03 20:00 
'*******************************************************************************

Public Function DiasHabiles(strFechaInicio As String, strFechaFin As String) As Long

Dim datFechaInicio As Date, _
  datFechaFin As Date

datFechaInicio = CDate(strFechaInicio)
datFechaFin = CDate(strFechaFin)

Do While datFechaInicio <> datFechaFin
   ' según la fecha de inicio se mayor o menor que la de fin
 If datFechaInicio >= datFechaFin Then
  If Weekday(datFechaFin, vbMonday) < 6 Then DiasHabiles = DiasHabiles + 1
  datFechaFin = datFechaFin + 1
 Else
  If Weekday(datFechaInicio, vbMonday) < 6 Then DiasHabiles = DiasHabiles + 1
  datFechaInicio = datFechaInicio + 1
   End If
Loop
End Function  ' DiasHabiles

'*******************************************************************************
'* Devuelve la fecha del cambio de Horario de Verano (ultimo domingo de Marzo)
'* del año pasado como argumento y en su defecto el actual
'* uso: txtVerano = CambioHorarioVerano
'* ESH 01/04/03 18:50
'*******************************************************************************

Public Function CambioHorarioVerano(Optional intAño As Integer) As Date

Dim datDia As Date, _
    bytDia As Byte
     
If intAño = 0 Then intAño = Year(Date)

' horario de verano (último domingo de Marzo)
bytDia = 31
datDia = DateSerial(intAño, 3, bytDia)

' busco el ultimo domingo (primero empezando por el final)
Do While Weekday(datDia) <> vbSunday
    datDia = DateSerial(intAño, 3, bytDia)
    bytDia = bytDia - 1
Loop

CambioHorarioVerano = datDia

End Function ' CambioHorarioVerano

'*******************************************************************************
'* Devuelve la fecha del cambio de Horario de Invierno (ultimo domingo de Octubre)
'* del año pasado como argumento y en su defecto el actual
'* uso: txtInvierno = CambioHorarioInvierno
'* ESH 01/04/03 18:55
'*******************************************************************************

Public Function CambioHorarioInvierno(Optional intAño As Integer) As Date

Dim datDia As Date, _
    bytDia As Byte
     
If intAño = 0 Then intAño = Year(Date)

' horario de invierno (ultimo domingo de Octubre)
bytDia = 31
datDia = DateSerial(intAño, 10, bytDia)

' busco el ultimo domingo (primero empezando por el final)
Do While Weekday(datDia) <> vbSunday
    datDia = DateSerial(intAño, 10, bytDia)
    bytDia = bytDia - 1
Loop

CambioHorarioInvierno = datDia

End Function ' CambioHorarioInvierno

'*******************************************************************************
'* devuelve Verdadero o Falso según el año sea bisiesto o no
'* uso If EsBisiesto Then
'* ESH 15/09/02 19:10
'*******************************************************************************

Private Function EsBisiesto(lngAño As Long) As Boolean
If DiasEnMes(DateSerial(lngAño, 2, 1)) = 29 Then EsBisiesto = True
End Function ' EsBisiesto

'*******************************************************************************
'* PrimerLunesAñoISO
'* Calcula la fecha del primer Lunes del Año de la fecha pasada
'* o de la actual por defecto
'* según la ISO 8601 la primera semana del año es la que tiene al menos cuatro
'* días del nuevo año
'* Argumentos: intAño => Opcional año
'* uso: PrimerLunesAñoISO
'* First published by John Green, Excel MVP, Sydney, Australia
'* ESH 20/04/05 15:48
'*******************************************************************************

Public Function PrimerLunesAñoISO(Optional intAño As Integer) As Date

Dim intDiaSemana As Integer, _
    datAñoNuevo As Date

On Error GoTo PrimerLunesAñoISO_TratamientoErrores

' si no paso ningún año, calculo con el actual
If intAño = 0 Then intAño = Year(Date)

datAñoNuevo = DateSerial(intAño, 1, 1)

intDiaSemana = (datAñoNuevo - 2) Mod 7
If intDiaSemana < 4 Then
    PrimerLunesAñoISO = datAñoNuevo - intDiaSemana
Else
    PrimerLunesAñoISO = datAñoNuevo - intDiaSemana + 7
End If

PrimerLunesAñoISO_Salir:
    On Error GoTo 0
    Exit Function

PrimerLunesAñoISO_TratamientoErrores:

    MsgBox "Error " & Err.Number & " en proc.: PrimerLunesAñoISO de Módulo: Módulo1 (" & Err.Description & ")"
    Resume PrimerLunesAñoISO_Salir
End Function            ' PrimerLunesAñoISO

'*******************************************************************************
'* NumeroSemanaISO
'* Calcula el número de semana de la fecha pasada o por defecto de la actual
'* según la ISO 8601 la primera semana del año es la que tiene al menos cuatro
'* días del nuevo año
'* Argumentos: datFecha => Opcional Fecha de calculo
'* uso: NumeroSemanaISO (Date)
'* Attributed to Daniel Maher
'* ESH 20/04/05 16:05
'*******************************************************************************

Public Function NumeroSemanaISO(Optional datFecha As Date) As Integer
Dim lngFecha As Long

On Error GoTo NumeroSemanaISO_TratamientoErrores

If datFecha = 0 Then datFecha = Date

lngFecha = DateSerial(Year(datFecha - Weekday(datFecha - 1) + 4), 1, 3)
NumeroSemanaISO = Int((datFecha - lngFecha + Weekday(lngFecha) + 5) / 7)

NumeroSemanaISO_Salir:
    On Error GoTo 0
    Exit Function

NumeroSemanaISO_TratamientoErrores:

    MsgBox "Error " & Err.Number & " en proc.: NumeroSemanaISO de Módulo: Módulo1 (" & Err.Description & ")"
    Resume NumeroSemanaISO_Salir
End Function            ' NumeroSemanaISO