La página Web de Emilio Sancha - MVP 2006/11
La página Web de Emilio Sancha

Inicio    |   Access    |   Excel    |    Visual Script    |   Enlaces    |   Búsquedas    |   Apuntes    |   Libro de Visitas

Suscripcion RSS

 

Calculo del número de la semana en el mes de la fecha pasada por argumento o en su defecto la actual
Conversión de un tiempo en formato horario (cadena o fecha) a formato decimal
Conversión de tiempo en minutos a formato hh:mm:00
Conversión de tiempo en segundos a formato mm:ss
Conversión de tiempo en segundos a formato hh:mm:ss
Conversión de una cadena con formato hora a minutos
Conversión de una cadena con formato hora a segundos
Calculo del primer día del año de la fecha pasada por argumento o en su defecto del actual
Calculo del mes de la fecha pasada por argumento o en su defecto del actual
Calculo del mes próximo a la fecha pasada por argumento o en su defecto del actual
Calculo del ultimo día del mes anterior al de la fecha pasada por argumento o en su defecto del actual
Calculo del ultimo día del mes de la fecha pasada como argumento o en su defecto de la actual
Calculo del ultimo día del siguiente mes de la fecha pasada como argumento o en su defecto la actual
Calculo del primer día del mes anterior al de la fecha pasada como argumento o en su defecto la actual
Calculo del primer día del mes de la fecha pasada como argumento o en su defecto la actual
Calculo del primer día del mes siguiente a la fecha pasada como argumento o en su defecto la actual
Calculo del primer día del trimestre de la fecha pasada como argumento o en su defecto la actual
Calculo del ultimo día del trimestre de la fecha pasada como argumento o en su defecto la actual
Calculo del primer día de la semana de la fecha pasada como parámetro o en su defecto de la actual
Calculo del ultimo día de la semana de la fecha pasada como parámetro o en su defecto de la actual
Calculo del tiempo transcurrido entre dos fechas / horas, devuelto expresado en días
Calculo del tiempo transcurrido entre dos fechas / horas, devuelto expresado en días, horas, minutos y segundos
Calculo de la suma de los tiempos almacenados en un campo de una tabla devuelto en formato de horas y minutos
Conversión del tiempo en minutos pasado como argumento a formato fecha
Devuelve la fecha de Hoy (evidentemente es igual que Now)
Devuelve la fecha de Mañana
Devuelve la fecha de Pasado Mañana
Devuelve la fecha de Ayer
Devuelve la fecha de Anteayer
Devuelve la fecha del lunes de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del martes de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del miércoles de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del jueves de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del viernes de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del sábado de la semana de fecha pasada como parámetro o en su defecto de la actual
Devuelve la fecha del domingo de la semana de fecha pasada como parámetro o en su defecto de la actual
Calculo de los días del mes pasado como argumento o en su defecto del actual
Calculo del número de la semana de la fecha pasada como argumento o en su defecto de la actual
Calculo de los días y/o los meses y/o los años transcurridos entre dos fechas
Calculo de la fecha móvil del Domingo de Pascua
Calculo de la fecha móvil del Sábado Santo
Calculo de la fecha móvil del Viernes Santo
Calculo de la fecha móvil del Jueves Santo
Calculo de la fecha móvil del Domingo de Ramos
Calculo de la fecha móvil del Miércoles de Ceniza
Calculo de la fecha móvil del Lunes de Pentecostés y/o la Virgen del Mar (Santander) y/o Virgen del Rocío (Huelva)
Conversión de números Romanos a Arábigos
Confirmación de la validez de la fecha pasada como argumento, devolviéndola si es valida con formato cadena dd/mm/aa y si procede hh:mm:ss
Calculo del número de días hábiles entre dos fechas (sin tener en cuenta los festivos entre semana)
Calculo de la fecha móvil del día del cambio a Horario de Verano (ultimo Domingo de Marzo)
Calculo de la fecha móvil del día del cambio a Horario de Invierno (ultimo Domingo de Octubre)
Como saber si un año es bisiesto o no
Calculo del primer lunes del año según la norma ISO8601
Calculo del número de semana del año según la norma ISO8601
Calculo de la Hora UTC (Greenwich)
 
'*******************************************************************************
'* Calcula el número de semana del mes, como diferencia entre la semana actual y
'* la del primer día de mes
'*******************************************************************************
Public Function SemanaMes(Optional datFecha As Date
If datFecha = 0 Then datFecha = Date
SemanaMes = Format(datFecha, "ww", vbMonday) - Format(DateSerial(Year(datFecha), Month(datFecha), 1), "ww", vbMonday) + 1
End Function            ' SemanaMes
Volver arriba
'*******************************************************************************
'* convierte un tiempo de formato horario (cadena o fecha) a formato decimal
'* uso: HoraADecimal("01/01/01") devuelve 885408
'*******************************************************************************
Function HoraADecimal(vntHoras As Variant) As Long
HoraADecimal = Round(CDbl(CDate(vntHoras)) * 24, 2)
End Function 	' HoraADecimal
Volver arriba
'*******************************************************************************
'* convierte tiempo en Minutos a formato hh:mm:00
'* uso: MinutosAhhmm(864) devuelve 14:24:00
'*******************************************************************************
Function MinutosAhhmm(intMinutos As Integer) As Date
MinutosAhhmm = intMinutos \ 60 & ":" & format((Abs(intMinutos Mod 60)), "00")
End Function 	' MinutosAhhmm
Volver arriba
'*******************************************************************************
'* convierte segundos a formato mm:ss
'* uso: SegundosAmmss(1865) devuelve 31:05
'*******************************************************************************
Function SegundosAmmss(lngSegundos As Long)
SegundosAmmss = (CInt(lngSegundos \ 60)) & ":" & format((Abs(CInt(lngSegundos Mod 60))), "00")
End Function 	' SegundosAmmss
Volver arriba
'*******************************************************************************
'* convierte segundos a formato hh:mm:ss
'* uso: SegundosAhhmmss(55000) devuelve 15:38:40
'* ESH 01/06/02 20:07
'*******************************************************************************
Function SegundosAhhmmss(lngSegundos As Long) As String
Dim strHoras As String, _
    strMinutos As String, _
    strSegundos As String

If IsNull(lngSegundos) Then SegundosAhhmmss = "": Exit Function

strHoras = format(lngSegundos \ 3600, "00")
strMinutos = format(((lngSegundos - (CLng(strHoras) * 3600)) \ 60), "00")
strSegundos = format(Abs(lngSegundos Mod 60), "00")

SegundosAhhmmss = strHoras & ":" & strMinutos & ":" & strSegundos
End Function 	' SegundosAhhmmss
Volver arriba
'*******************************************************************************
'* convierte una cadena con formato hora a minutos
'* uso: hhmmAMinutos("12:01") devuelve 721
'*******************************************************************************
Function hhmmAMinutos(strHoras) As Long
hhmmAMinutos = CLng(CDbl(CDate(strHoras)) * 24 * 60)
End Function 	' hhmmAMinutos
Volver arriba
'*******************************************************************************
'* convierte una cadena con formato hora a segundos
'* uso: hhmmASegundos("12:01") devuelve 43260
'*******************************************************************************
Function hhmmASegundos(vntHoras) As Long
hhmmASegundos = CLng(CDbl(CDate(vntHoras)) * 24 * 60 * 60)
End Function 	' hhmmASegundos
Volver arriba
'*******************************************************************************
'* como obtener distintas fechas en relación a la pasada como argumento
'*******************************************************************************
' Devuelve el primer día del año de la fecha pasada por argumento y en su defecto del actual
Public Function PrimerDiaAño(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
PrimerDiaAño = DateSerial(CInt(Year(datFecha)), 1, 1)
End Function 	' PrimerDiaAño
Volver arriba
' Devuelve el mes de la fecha pasada por argumento o en su defecto de la actual
Function MesActual(Optional datFecha As Date) As Byte
If datFecha = "0:00:00" Then datFecha = Date
MesActual = Month(datFecha)
End Function 	' MesActual
Volver arriba
' Devuelve el siguiente mes a la fecha pasada como parametro o en su defecto de la actual
Function MesProximo(Optional datFecha As Date) As Byte
If datFecha = "0:00:00" Then datFecha = Date
MesProximo = Month(datFecha)  + 1
If MesProximo = 13 Then MesProximo = 1
End Function 	' MesProximo
Volver arriba
' Devuelve el ultimo día del mes pasado a la fecha pasada como parametro o en su defecto la actual 
Function UltimoDiaMesPasado(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
UltimoDiaMesPasado = DateSerial(Year(datFecha), Month(datFecha) + 0, 0)
End Function 	' UltimoDiaMesPasado
Volver arriba
' Devuelve el ultimo día del mes de la fecha pasada como argumento o en su defecto de la actual
Function UltimoDiaMes(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
UltimoDiaMes = DateSerial(Year(datFecha), Month(datFecha) + 1, 0)
End Function 	' UltimoDiaMes
Volver arriba
' Devuelve el ultimo día del siguiente mes de la fecha pasada como argumento o en su defecto la actual
Function UltimoDiaMesProximo(Optional datFecha As Date) As Date
If datFecha = "0:00:00"; Then datFecha = Date
UltimoDiaMesProximo = DateSerial(Year(datFecha), Month(datFecha) + 2, 0)
End Function 	' UltimoDiaMesProximo
Volver arriba
' Devuelve el primer día del mes pasado de la fecha pasada como argumento o en su defecto la actual 
Function PrimerDiaMesPasado(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
PrimerDiaMesPasado = DateSerial(Year(datFecha), Month(datFecha) - 1, 1)
End Function 	' PrimerDiaMesPasado
Volver arriba
' Devuelve el primer día del mes de la fecha pasada como argumento o en su defecto la actual
Function PrimerDiaMes(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
PrimerDiaMes = DateSerial(Year(datFecha), Month(datFecha), 1)
End Function 	' PrimerDiaMes
Volver arriba
' Devuelve el primer día del trimestre de la fecha pasada como argumento o en su defecto la actual
Function PrimerDiaTrimestre(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
PrimerDiaTrimestre = DateSerial(Year(datFecha), Int((Month(datFecha) - 1) / 3) * 3 + 1, 1)
End Function 	' PrimerDiaTrimestre
Volver arriba
' Devuelve el ultimo día del trimestre de la fecha pasada como argumento o en su defecto la actual
Function UltimoDiaTrimestre(Optional datFecha As Date) As Date
If datFecha = "0:00:00" Then datFecha = Date
UltimoDiaTrimestre = DateSerial(Year(datFecha), Int((Month(datFecha) - 1) / 3) * 3 + 4, 0)
End Function 	' UltimoDiaTrimestre
Volver arriba
'*******************************************************************************
'* Devuelve el primer día de la semana de la fecha pasada como parametro o en su defecto de la actual
'* uso: PrimerDiaSemana("11/01/01")
'*******************************************************************************
Public Function PrimerDiaSemana(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
PrimerDiaSemana = datFecha - Weekday(datFecha, 2) + 1
End Function 	' PrimerDiaSemana
Volver arriba
' Devuelve el ultimo día de la semana
Public Function UltimoDiaSemana(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
UltimoDiaSemana = datFecha - Weekday(datFecha, 2) + 7
End Function 	' UltimoDiaSemana  
Volver arriba
'*******************************************************************************
'* calcula el tiempo transcurrido entre dos fechas / horas y lo devuelve expresado en días
'* uso: DiasTrascurridos("15/09/1999", "15/09/2001") devuelve 731,00 Días
'*******************************************************************************

Function DiasTranscurridos(strInicio As String, strFin As String) As String
Dim dblDias As Double

' calculo el tiempo transcurrido
dblDias = Round((CDate(strFin) - CDate(strInicio)), 2)
' lo formateo y devuelvo
If dblDias > 1 Then
    DiasTranscurridos = format(dblDias, "#,###.00") & " Días"
Else
    DiasTranscurridos = format(dblDias, "#,###.00") & " Día"
End If ' dblDias > 1
End Function 	' DiasTranscurridos
Volver arriba
'*******************************************************************************
'* calcula el tiempo transcurrido entre dos fechas / horas y lo devuelve expresado 
'* en días, horas, minutos y segundos
'* uso: TiempoTranscurrido("15/09/1956", cStr(Now)) 
'* devuelve 16.237 Días, 9 Horas, 58 Minutos y 20 Segundos
'*******************************************************************************

Function TiempoTranscurrido(Inicio As String, Fin As String) as String
Dim lngTotalHoras As Long, _
	lngTotalMinutos As Long, _
	lngTotalSegundos As Long, _
	lngDias As Long, _
	lngHoras As Long, _
	lngMinutos As Long, _
	lngSegundos As Long, _
	dblIntervalo As Double

' calculo el intervalo de tiempo
dblIntervalo = CDate(Fin) - CDate(Inicio)
' lo descompongo en sus partes
lngDias = Int(CSng(dblIntervalo))
lngTotalHoras = Int(CSng(dblIntervalo * 24)) 		' total horas en el periodo
lngTotalMinutos = Int(CSng(dblIntervalo * 1440)) 	' total minutos en el periodo
lngTotalSegundos = Int(CSng(dblIntervalo * 86400)) ' total segundos en el periodo
lngHoras = lngTotalHoras Mod 24 					' me quedo solo con los restos
lngMinutos = lngTotalMinutos Mod 60
lngSegundos = lngTotalSegundos Mod 60
' lo devuelvo
TiempoTranscurrido = Format(lngDias, "#,###") & " Días, " & lngHoras & " Horas, " & _
                            lngMinutos & " Minutos y " & lngSegundos & " Segundos"
End Function	' TiempoTranscurrido
Volver arriba
'*******************************************************************************
'* Devuelve la suma de los tiempos almacenados en un campo de una tabla y lo presenta
'* en formato de horas y minutos
'*******************************************************************************
Function TotalTiempoTabla(strBaseDatos As String, strTabla As String, strCampo As String) As String
Dim dbs As Database, _
rst As Recordset, _
lngTotalHoras As Long, _ lngTotalMinutos As Long, _
lngDias As Long, _
lngHoras As Long, _
lngMinutos As Long, _
dblPeriodo As Double, _
strFiltro As String
' abro un recordset con los valores a totalizar strFiltro = "SELECT " & strCampo & " FROM " & strTabla & " WHERE " & strCampo & " IS NOT NULL" Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strFiltro)
While Not rst.EOF
dblPeriodo = dblPeriodo + rst(strCampo)
rst.MoveNext
Wend 	' Not rst.EOF
lngTotalHoras = Int(CSng(dblPeriodo * 24))
lngTotalMinutos = Int(CSng(dblPeriodo * 1440))
lngHoras = lngTotalHoras Mod 24
lngMinutos = lngTotalMinutos Mod 60
TotalTiempoTabla = lngTotalHoras & " horas y " & lngMinutos & " minutos"
End Function 	' TotalTiempoTabla
Volver arriba
'*******************************************************************************
'* devuelve el valor pasado como argumento en minutos, convertido a formato fecha para
'* poder operar con ello
'* uso: Periodo(lngPeriodo)
'*******************************************************************************
Public Function Periodo(lngPeriodo As Long) As Date
Dim dblMinuto As Double
dblMinuto = 1 / 1440 						' calculo el valor de un minuto
Periodo = CDate(lngPeriodo * dblMinuto) 	' convierto los minutos
End Function 	' Periodo
Volver arriba
'*******************************************************************************
'* conjunto de funciones para calcular la fecha relativa al día actual o al día de la
'* semana
'*******************************************************************************
Public Function Hoy() As Date
Hoy = Date
End Function 	' Hoy
Volver arriba
Public Function Mañana() As Date
Mañana = Date + 1
End Function 	' Mañana
Volver arriba
Public Function PasadoMañana() As Date
PasadoMañana = Date + 2
End Function 	' PasadoMañana
Volver arriba
Public Function Ayer() As Date
Ayer = Date - 1
End Function 	' Ayer
Volver arriba
Public Function AnteAyer() As Date
AnteAyer = Date - 2
End Function 	' AnteAyer
Volver arriba
Public Function Lunes(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Lunes = datFecha - Weekday(datFecha, 2) + 1
End Function 	' Lunes
Volver arriba
Public Function Martes(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Martes = datFecha - Weekday(datFecha, 2) + 2
End Function 	' Martes
Volver arriba
Public Function Miercoles(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Miercoles = datFecha - Weekday(datFecha, 2) + 3
End Function 	' Miercoles
Volver arriba
Public Function Jueves(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Jueves = datFecha - Weekday(datFecha, 2) + 4
End Function 	' Jueves
Volver arriba
Public Function Viernes(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Viernes = datFecha - Weekday(datFecha, 2) + 5
End Function 	' Viernes
Volver arriba
Public Function Sabado(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Sabado = datFecha - Weekday(datFecha, 2) + 6
End Function 	' Sabado
Volver arriba
Public Function Domingo(Optional datFecha As Date) As Date
If datFecha = "0:00:00 " Then datFecha = Date
Domingo = datFecha - Weekday(datFecha, 2) + 7
End Function 	' Domingo
Volver arriba
'*******************************************************************************
'* DiasEnMes
'* función que calcula el número de días del mes de la fecha pasada como parametro
'* o en su defecto la actual
'* Argumentos: opcional datFecha => cualquier dato considerable como fecha
'* uso: DiasEnMes("01/02/2000") / DiasEnMes(Date) / DiasEnMes(37933)
'* ESH 08/11/03 19:06
'*******************************************************************************

Function DiasEnMes(Optional datFecha As Date) As Integer
If datFecha = "0:00:00" Then datFecha = Date
DiasEnMes = Day(DateSerial(Year(datFecha), Month(datFecha) + 1, 0))
End Function     
' DiasEnMes

Volver arriba
'*******************************************************************************
'* Semana
'* Función que devuelve la semana a la que pertenece el día pasado como argumento
'* o en su defecto la actual, tomando como primera semana aquella en que esta el
'* día 1 de enero
'* Argumentos: opcional datFecha => cualquier dato considerable como fecha
'* uso: Semana(Date) / Semana("08/11/03") / Semana(37933)
'* ESH 08/11/03 19:12
'*******************************************************************************

Public Function Semana(Optional datFecha As Date) As Integer
If datFecha = "0:00:00" Then datFecha = Date
Semana = DatePart("ww", datFecha, vbMonday)
End Function
      ' Semana

Volver arriba
'*******************************************************************************
'* Devuelve los días y/o los meses y/o los años transcurridos entre dos fechas
'* deberá incluir la definición de tipo en la sección de declaraciones de un modulo
'* Type Edad
'* 	Dias As Byte
'* 	Meses As Byte
'* 	Años As Integer
'* End Type
'* uso: Edad("15/1/01", Date).Dias devuelve los dias transcurridos desde el 15/01/01 hasta hoy
'* ESH 01/06/01 19:52
'*******************************************************************************
Public Function Edad(strFechaInicio As String, strFechaFin As String) ' As Edad
Dim bytDias As Byte, _
	bytMeses As Byte, _
	intAños As Integer, _
	strPrimeraFecha As String, _
	strSegundaFecha As String
' ordeno correctamente las fechas
If CDate(strFechaInicio) < CDate(strFechaFin) Then
	strPrimeraFecha = strFechaInicio
	strSegundaFecha = strFechaFin
Else
	strSegundaFecha = strFechaInicio
	strPrimeraFecha = strFechaFin
End If 	' strFechaInicio < strFechaFin
' calculo la diferencia en años
intAños = DateDiff("yyyy", strPrimeraFecha, strSegundaFecha)
If format(CDate(strSegundaFecha), "mmdd") < format(CDate(strPrimeraFecha), "mmdd") Then
	intAños = intAños - 1
End If 	' format(strSegundaFecha, "mmdd") < format(strPrimeraFecha, "mmdd")
' calculo la diferencia en meses
bytMeses = DateDiff("m", strPrimeraFecha, strSegundaFecha) - (intAños * 12)
' calculo la diferencia en días
bytDias = DateDiff("d", format(strPrimeraFecha, "dd"), format(strSegundaFecha, "dd"))
If bytDias < 0 Then
	bytMeses = bytMeses - 1
	bytDias = DateDiff("d", DateSerial(Year(strSegundaFecha), Month(strSegundaFecha) -, _
                     Day(strPrimeraFecha)), strSegundaFecha)
End If 	' bytDias < 0
' en cada caso devuelvo su valor
Edad.Dias = bytDias
Edad.Meses = bytMeses
Edad.Años = intAños
End Function 	' Edad
Volver arriba
'*******************************************************************************
'* DomingoPascua
'* devuelve la fecha del Domingo de Pascua (Resurrección) del año pasado como
'* argumento o en su defecto la actual
'* Argumentos: opcional intAño => Año
'* uso: DomingoPascua intAño
'* ESH 12/09/01 12:20
'*******************************************************************************
Public Function DomingoPascua(Optional intAño As Integer) As Date
     Dim datDomingoPascua As Date, _
     G As Integer, _
     C As Integer, _
     X As Integer, _
     Z As Integer, _
     E As Integer, _
     D As Integer, _
     intDia As Integer, _
     intMes As Integer
If intAño = 0 Then intAño = Year(Date)
G = intAño Mod 19 + 1
C = intAño \ 100 + 1
X = (3 * C) \ 4 - 12: Z = ((8 * C) + 5) \ 25 - 5
D = (5 * intAño) \ 4 - X - 10
E = (11 * G + 20 + Z - X) Mod 30
If (E = 25 And G > 11) Or E = 24 Then E = E + 1
intDia = 44 - E
If intDia < 21 Then intDia = intDia + 30
intDia = intDia + 7 - ((D + intDia) Mod 7)
intMes = 3
If intDia > 31 Then
	intMes = 4
	intDia = intDia - 31
End If ' intDia > 31
datDomingoPascua = DateSerial(intAño, intMes, intDia)
DomingoPascua = datDomingoPascua
End Function 	' DomingoPascua
Volver arriba
'*******************************************************************************
'* Funciones que devuelven las fechas de los festivos moviles de Semana Santa del
'* año pasado como parametro
'* debe incluirse la función DomingoPascua
'* uso: txtSabadoSanto = SabadoSanto(intAño)
'* ESH 12/09/01 13:35
'*******************************************************************************
Public Function SabadoSanto(intAño As Integer) As Date
SabadoSanto = DomingoPascua(intAño) - 1
End Function 	' SabadoSanto
Volver arriba
Public Function ViernesSanto(intAño As Integer) As Date
ViernesSanto = DomingoPascua(intAño) - 2
End Function 	' ViernesSanto
Volver arriba
Public Function JuevesSanto(intAño As Integer) As Date
JuevesSanto = DomingoPascua(intAño) - 3
End Function 	' JuevesSanto
Volver arriba
Public Function DomingoRamos(intAño As Integer) As Date
DomingoRamos = DomingoPascua(intAño) - 7
End Function 	' DomingoRamos
Volver arriba
Public Function MiercolesCeniza(intAño As Integer) As Date
MiercolesCeniza = DomingoPascua(intAño) - 46
End Function 	' MiercolesCeniza
Volver arriba
'*******************************************************************************
'* LunesPentecostes
'* devuelve la fecha móvil de la festividad del Lunes de Pentecostés y/o la Virgen del 
'* Rocío en Huelva y/o la Virgen del Mar en Santander, del año pasado como argumento 
'* o en su defecto la actual
'* debe incluirse la función DomingoPascua
'* Argumentos: opcional intAño => Año
'* uso:
'* ESH 08/11/03 19:33
'*******************************************************************************
Public Function LunesPentecostes(Optional intAño As Integer) As Date
If intAño = 0 Then intAño = Year(Date)
LunesPentecostes = DomingoPascua(intAño) + 50
End Function      ' LunesPentecostes
Volver arriba
'*******************************************************************************
'* Función que descifra números romanos y los convierte en arábigos
'* uso: NumArabigo ("MCMXCVIII") devuelve 1998
'* ESH 10/10/01 11:37
'*******************************************************************************
Function NumArabigo(strNumRomano As String) As Integer
' dimensiono variables
Dim ValorNumArabigo() As Integer, _
	 strCaracter As String * 1, _
	 i As Integer, _
	 intTotalCaracteres As Integer
' compruebo la sintaxis
SeCumple InStr(strNumRomano, "IIII") = 0, , True
SeCumple InStr(strNumRomano, "VV") = 0
SeCumple InStr(strNumRomano, "XXXX") = 0
SeCumple InStr(strNumRomano, "LL") = 0
SeCumple InStr(strNumRomano, "CCCC") = 0
SeCumple InStr(strNumRomano, "DD") = 0
If Not SeCumple Then
	NumArabigo = "La sintáxis de " & strNumRomano & " no es correcta"
	Exit Function
End If 	' Not SeCumple
' quito espacios
strNumRomano = Trim(strNumRomano)
' cuento caracteres
intTotalCaracteres = Len(strNumRomano)
' si el argumento es nulo salgo
If intTotalCaracteres = 0 Then
	NumArabigo = ""
	Exit Function
End If ' intTotalCaracteres = 0
' dimensiono la matriz al número de caracteres totales
ReDim ValorNumArabigo(intTotalCaracteres)
' convierto cada caracter Romano a su valor equivalente Arábigo
For i = 1 To intTotalCaracteres
   strCaracter = Mid(strNumRomano, i, 1)
   Select Case UCase(strCaracter)
   Case "M"
   	ValorNumArabigo(i) = 1000
   Case "D"
   	ValorNumArabigo(i) = 500
   Case "C"
   	ValorNumArabigo(i) = 100
   Case "L"
   	ValorNumArabigo(i) = 50
   Case "X"
   	ValorNumArabigo(i) = 10
   Case "V"
  		ValorNumArabigo(i) = 5
   Case "I"
   	ValorNumArabigo(i) = 1
   ' si ALGUNO de los caracteres no es válido, muestro un mensaje y salgo
   Case Else
   	NumArabigo = "La sintáxis de " & strNumRomano & " no es correcta"
	Exit Function
   End Select 	' Case UCase(strCaracter)
Next i
' si algún valor es menor que el valor a su derecha, convierto ese valor en negativo
For i = 1 To intTotalCaracteres - 1
	If ValorNumArabigo(i) < ValorNumArabigo(i + 1) Then
		ValorNumArabigo(i) = ValorNumArabigo(i) * -1
	End If '* ValorNumArabigo(i) < ValorNumArabigo(i + 1)
Next ' i = 1 To intTotalCaracteres - 1
' devuelvo el valor en Arábigo
For i = 1 To intTotalCaracteres
   NumArabigo = NumArabigo + ValorNumArabigo(i)
Next ' i = 1 To intTotalCaracteres
End Function	' NumArabigo
Volver arriba
'*******************************************************************************
'* 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
Volver arriba
'*******************************************************************************
'* 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
Volver arriba
'*******************************************************************************
'* 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
Volver arriba
'*******************************************************************************
'* 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
Volver arriba
'*******************************************************************************
'* 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

Volver arriba
'*******************************************************************************
'* 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 IntegerAs 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
Volver arriba
'*******************************************************************************
'* 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 DateAs 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
 
Volver arriba
' Devuelve el primer día del siguiente mes de la fecha pasada como argumento o en su defecto la actual
Function PrimerDiaMesProximo(Optional datFecha As DateAs Date
If datFecha = 0 Then datFecha = Date
PrimerDiaMesProximo = DateSerial(Year(datFecha), Month(datFecha) + 1, 1)
End Function   ' PrimerDiaMesProximo
Volver arriba
'*******************************************************************************
'* HoraUTC
'* convierte a UTC la hora pasada como parámetro o en su defecto la actual
'* Deberá incluir en la sección de declaraciones de un módulo las siguientes
'* Public Declare Sub GetSystemTime Lib "kernel32" (lpHoraSistema As HoraSistema)
'*
'* Public Type HoraSistema
'*    stAño As Integer
'*    stMes As Integer
'*    stDiaSemana As Integer
'*    stDia As Integer
'*    stHora As Integer
'*    stMinuto As Integer
'*    stSegundo As Integer
'*    stMilisegundos As Integer
'* End Type
'* Argumentos: datHora => (opcional) hora a convertir en UTC
'* uso: HoraUTC (#05/04/07 18:25#)
'* ESH 09/05/07 19:12
'*******************************************************************************
 
Public Function HoraUTC(Optional datHora As DateAs Date
Dim stHora As HoraSistema, _
    datAhoraUTC As Date
 
' getSystemTime devuelve la hora UTC del sistema
GetSystemTime stHora
 
' convierto la hora a formato "legible"
With stHora
   datAhoraUTC = DateSerial(.stAño, .stMes, .stDia) + TimeSerial(.stHora, .stMinuto, .stSegundo)
End With
' si no hemos pasado hora a convertir, devuelvo la actual
' en caso contrario devuelvo la hora pasada convertida a UTC
If datHora = 0 Then
   HoraUTC = datAhoraUTC
Else
   HoraUTC = datHora + (datAhoraUTC - Now)
End If
End Function         ' HoraUTC
Volver arriba

NOTA: La información contenida en esta página, así como el código fuente incluido en la misma, se proporciona TAL CUAL, sin garantías de ninguna clase, y no otorga derecho alguno. Usted asume cualquier riesgo al poner en práctica, utilizar o ejecutar lo explicado, recomendado o sugerido en la presenta página.

This page is provided AS IS with no warranties, and confers no rights. You assume all risk for your use.

Ultima actualización:  Sábado, 15 de Octubre de 2016
© Emilio Sancha 2.004-2.016