La
página Web de Emilio Sancha
|
|
Inicio | Access | Excel | Visual Script | Enlaces | Búsquedas | Apuntes | Libro de Visitas |
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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
' 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 |
' 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 |
' 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 |
' 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 |
' 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 |
' 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 |
' 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 |
' 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 |
' 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 |
'******************************************************************************* '* 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 |
' 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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, _ 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
Public Function Mañana() As Date Mañana = Date + 1 End Function ' Mañana |
Public Function PasadoMañana() As Date PasadoMañana = Date + 2 End Function ' PasadoMañana |
Public Function Ayer() As Date Ayer = Date - 1 End Function ' Ayer |
Public Function AnteAyer() As Date AnteAyer = Date - 2 End Function ' AnteAyer |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
'******************************************************************************* Function DiasEnMes(Optional datFecha As Date) As Integer |
'******************************************************************************* Public Function Semana(Optional datFecha As Date) As Integer |
'******************************************************************************* '* 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 |
'******************************************************************************* 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 |
'******************************************************************************* '* 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 |
Public Function ViernesSanto(intAño As Integer) As Date ViernesSanto = DomingoPascua(intAño) - 2 End Function ' ViernesSanto |
Public Function JuevesSanto(intAño As Integer) As Date JuevesSanto = DomingoPascua(intAño) - 3 End Function ' JuevesSanto |
Public Function DomingoRamos(intAño As Integer) As Date DomingoRamos = DomingoPascua(intAño) - 7 End Function ' DomingoRamos |
Public Function MiercolesCeniza(intAño As Integer) As Date MiercolesCeniza = DomingoPascua(intAño) - 46 End Function ' MiercolesCeniza |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* '* 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 |
'******************************************************************************* 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 |
'******************************************************************************* Private Function EsBisiesto(lngAño As Long) As Boolean |
'******************************************************************************* |
'******************************************************************************* |
' 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 Date) As Date
If datFecha = 0 Then datFecha = Date
PrimerDiaMesProximo = DateSerial(Year(datFecha), Month(datFecha) + 1, 1)
End Function ' PrimerDiaMesProximo
|
'* 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 Date) As 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
|
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 |