Dicas do OsmarJr

Cálculo de intervalo entre datas


Função para cálculo do intervalo entre datas que apresenta anos, meses e dias.

O Renato Santos encaminhou esta função para uso de todos.

Option Compare Database
Option Explicit

'    Função para cálculo do intervalo de tempo entre duas datas
'    Apresenta o resultado com anos, meses e dias
'    Desenvolvida por Renato Santos - rebornbr@msn.com
'    Data: Out/05

Function Intervalo(DtI As Date, DtF As Date) As String

     If DtF <= DtI Then Exit Function
   
     Dim DataI As Long, DataF As Long
     Dim Calculo As String
     Dim Anos As Integer, Meses As Integer, Dias As Integer
     Dim ComplAnos As String, ComplMeses As String, ComplDias As String
   
     DataI = Format(DtI, "yyyy") & Format(DtI, "mm") & Format(DtI, "dd")
     DataF = Format(DtF, "yyyy") & Format(DtF, "mm") & Format(DtF, "dd")
     Calculo = Format(DataF - DataI, "00000000")
   
'    Verifica anos
     Anos = Left(Calculo, 4)

'    Verifica meses
     Meses = IIf(Mid(Calculo, 5, 2) < 12, Mid(Calculo, 5, 2), Mid(Calculo, 5, 2) - 88)
   
'    Verifica dias
     If Left(DataF, 6) = Left(DataI, 6) Then
          Dias = Right(Calculo, 2)
     Else
          Select Case Mid(DataF, 5, 2)
               Case Is = 3
                    If Day(DateSerial(Left(DataF, 4), 3, 0)) = 29 Then
                         Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 71)
                    Else
                         Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 72)
                    End If
               Case Is = 1, 2, 4, 6, 8, 9, 11
                    Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 69)
               Case Is = 5, 7, 10, 12
                    Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 70)
          End Select
     End If

'    Formata complementos
     ComplAnos = IIf(Anos = 0, "", IIf(Anos = 1, " ano", " anos"))
     ComplMeses = IIf(Meses = 0, "", IIf(Meses = 1, " mês", " meses"))
     ComplDias = IIf(Dias = 0, "", IIf(Dias = 1, " dia", " dias"))

'    Formata resultado
     If Anos = 0 And Meses = 0 And Dias > 0 Then
          Intervalo = Dias & ComplDias
     End If
     If Anos = 0 And Meses > 0 And Dias = 0 Then
          Intervalo = Meses & ComplMeses
     End If
     If Anos > 0 And Meses = 0 And Dias = 0 Then
          Intervalo = Anos & ComplAnos
     End If
     If Anos > 0 And Meses > 0 And Dias = 0 Then
          Intervalo = Anos & ComplAnos & " e " & Meses & ComplMeses
     End If
     If Anos > 0 And Meses = 0 And Dias > 0 Then
          Intervalo = Anos & ComplAnos & " e " & Dias & ComplDias
     End If
     If Anos = 0 And Meses > 0 And Dias > 0 Then
          Intervalo = Meses & ComplMeses & " e " & Dias & ComplDias
     End If
     If Anos > 0 And Meses > 0 And Dias > 0 Then
          Intervalo = Anos & ComplAnos & ", " & Meses & ComplMeses & " e " & Dias & ComplDias
     End If

End Function

Home

Contato | Copyright©Osmar José Correia Júnior | 24-Nov-2005 18:23