Re: Date duration function that returns years, months, weeks and days?



Bob Barrows wrote:
Larry Serflaten wrote:
"HAL07" <yahoohal@xxxxxxxxxxxxxxxx> wrote


thanks for helping me write one, however I asked if anybody had such
a function ready.
See if this helps....

LFS


Public Sub DateIntervals(ByVal Date1 As Date, ByVal Date2 As Date,

OK, I was bored so I created a vbscript version of this:

'initialize all the argument variables keeping in mind that there are no
optional arguments in vbscript procedures.
Birthday=#5/18/1975 09:00#
Yr=0 ' 0 or greater says "calculate this value"
Mo=0
Dy=0
Wk=0
Hr=0
Mn=-1 ' -1 says "don't calculate this value"
Sec=0
DateIntervals Birthday, Now, Yr, Mo,Wk, Dy, Hr, Mn, Sec
msgbox "You are " & Yr & " years, " & Mo & " months, " & _
Wk & " weeks, " & Dy & " days, " & Hr & " hours and " & _
Sec & " seconds old"

Public Sub DateIntervals(ByVal Date1, ByVal Date2, Yr, _
Mo,Wk, Dy, Hr, Mn, Sec)
Dim swap, test
Dim i, itr
Const interval = "ymwdhns"
' Returns the greatest full interval (yr, mo, day, hr, min, sec) between
two dates
' Calling procedure supplies variable(s) for the desired interval(s)

Prams=Array(Yr, Mo, Wk,Dy, Hr, Mn, Sec)

If (DateValue(Date1) = 0) Xor (DateValue(Date2) = 0) Then
' Assume today if one is a time and the other is a date...
If DateValue(Date1) = 0 Then Date1 = Date1 + DateValue(Now)
If DateValue(Date2) = 0 Then Date2 = Date2 + DateValue(Now)
End If

If Date1 > Date2 Then
' Swap dates if first is after second...
swap = Date1
Date1 = Date2
Date2 = swap
End If

For i = 0 To UBound(Prams)
If Prams(i) > -1 Then
itr = Mid(interval, i+1, 1)
itr=replace(replace(itr,"w","ww"),"y","yyyy")
' itr=replace(itr,"y","yyyy")
Prams(i) = DateDiff(itr, Date1, Date2)
Prams(i) = Prams(i) + (DateAdd(itr, Prams(i), Date1) > Date2)
Date1 = DateAdd(itr, Prams(i), Date1)
End If
Next 'i
Yr=Prams(0)
Mo=Prams(1)
Wk=Prams(2)
Dy=Prams(3)
Hr=Prams(4)
Mn=Prams(5)
Sec=Prams(6)

End Sub



Thank you very much Larry :)

--
-- HAL07, Engineering Services, Norway
.