Elegant code for TimeSince()

[Ellis Dee]

I'm writing what I thought was going to be a simple function to describe a time in the past, but it's quickly becoming way more complex than I expected.

The purpose is for a personal backup routine, so I don't technically "need" this, but it's become a puzzle I'm fascinated by. I'm hoping there's some clever tricks with DateSerial() or whatever to tighten this code up from being a total mess.

The goal is to be able to go back an arbitrary amount of time, up to years (but not decades) and always return a string with the two most significant values. Sample outputs would be:

37 seconds ago
13 minutes, 5 seconds ago
1 hour, 12 minutes ago
3 days, 4 hours ago
2 weeks, 1 day ago
6 months, 2 weeks ago
1 year, 2 months ago

I start by DateDiff()ing the difference in seconds. A long can go up to 68 years worth of seconds, so that's plenty. I also set up a helper function to handle pluralization because that's how I roll:

Private Function Plural(plngNumber As Long, pstrSingular As String) As String
    If plngNumber = 1 Then Plural = "1 " & pstrSingular Else Plural = plngNumber & " " & pstrSingular & "s"
End Function

Things started getting weird when I got to "x months, y weeks." Here's what I have so far:

' Arbitrary value for "blank" date
Public Const NullDate As Date = #1/27/1991# ' WIDE RIGHT!!!!!
 
Public Function TimeSince(pdtmDate As Date) As String
    Dim lngYears As Long
    Dim lngMonths As Long
    Dim lngWeeks As Long
    Dim lngDays As Long
    Dim lngHours As Long
    Dim lngMinutes As Long
    Dim lngSeconds As Long
    Dim strReturn As String
    
    Do While pdtmDate <> NullDate 
        ' Seconds
        lngSeconds = DateDiff("s", pdtmDate, Now())
        If lngSeconds <= 60 Then
            strReturn = Plural(lngSeconds, "second")
            Exit Do
        End If
        ' Minutes, Seconds
        lngMinutes = lngSeconds \ 60
        lngSeconds = lngSeconds - lngMinutes * 60
        If lngMinutes <= 60 Then
            strReturn = Plural(lngMinutes, "minute") & ", " & Plural(lngSeconds, "second")
            Exit Do
        End If
        ' Hours, Minutes
        lngHours = lngMinutes \ 60
        lngMinutes = lngMinutes - lngHours * 60
        If lngHours <= 24 Then
            strReturn = Plural(lngHours, "hour") & ", " & Plural(lngMinutes, "minute")
            Exit Do
        End If
        ' Days, Hours
        lngDays = lngHours \ 24
        lngHours = lngHours - lngDays * 24
        If lngDays <= 7 Then
            strReturn = Plural(lngDays, "day") & ", " & Plural(lngHours, "hour")
            Exit Do
        End If
        ' Weeks, Days
        If pdtmDate >= DateAdd("m", -1, Now()) Then
            lngWeeks = lngDays \ 7
            lngDays = lngDays - lngWeeks * 7
            strReturn = Plural(lngWeeks, "week") & ", " & Plural(lngDays, "day")
            Exit Do
        End If
        ' Months, Weeks
        ' ???
        ' Years, Months
        ' ???
        Exit Do
    Loop
    If Len(strReturn) Then strReturn = strReturn & " ago" Else strReturn = "Never"
    TimeSince = strReturn
End Function

[Arnoutdv]

I thought I had an "elegant" solution, but it's not correct
The problem being DateDiff() returning integers and literally doing (A - B) + 1, for example for years.
Then I also read this in the help for DateDiff

When comparing December 31 to January 1 of the immediately succeeding year, DateDiff for Year ("yyyy") returns 1 even though only a day has elapsed.

Not correct working code ahead:

Private Function TimeSince(dtDate As Date) As String
  Dim dtNow As Date
  Dim lValues(6) As Long ' year, month, week, day, hour, minute, second
  Dim lDiff As Long
  Dim aText() As String
  Dim i As Long
  
  If dtDate = 0 Then Exit Function
  
  aText = Split("years,months,weeks,days,hours,minutes,seconds", ",")
  dtNow = Now
  
  lValues(0) = DateDiff("yyyy", dtDate, dtNow)        ' number of year
  lValues(1) = DateDiff("m", dtDate, dtNow) Mod 12    ' number of months
  lDiff = DateDiff("d", dtDate, dtNow)
  lValues(2) = (lDiff / 7) Mod 5                      ' number of weeks
  lValues(3) = lDiff Mod 7                            ' number of days
  lValues(4) = DateDiff("h", dtDate, dtNow) Mod 24    ' number of hours
  lValues(5) = DateDiff("n", dtDate, dtNow) Mod 60    ' number of minutes
  lValues(6) = DateDiff("s", dtDate, dtNow) Mod 60    ' number of seconds
  
  For i = 0 To 6
    If lValues(i) <> 0 Then
      TimeSince = lValues(i) & " " & aText(i)
      If i <> 6 Then
        TimeSince = TimeSince & ", " & lValues(i + 1) & " " & aText(i + 1)
      End If
      Exit For
    End If
  Next i
End Function

[si_the_geek]

I've written similar code to post #1 before, and I don't think I've seen anything noticeably better... but the months and years are a bit tricky, as you need to take into account varying days per month and leap years.

I can't find the posts here I've seen over the years that solved it nicely... however, you can do this to calculate the months:

        lngMonths = (Year(Now) - Year(pdtmDate)) * 12 + (Month(Now) - Month(pdtmDate))
        If Day(Now) < Day(pdtmDate) Then lngMonths = lngMonths -1

...but in order to get the weeks too, you need to recalculate ignoring the months:

        lngWeeks = DateDiff("d", DateAdd("m", pdtmDate, lngMonths), Now) \ 7

Once you have the months, the "Years, Months" calculation is along the lines of:

        lngYears = lngMonths \ 12
        lngMonths = lngMonths Mod 12

All this code is written directly to the forums so may have minor mistakes, but should be close enough to work it out.

[Ellis Dee]

I

        lngMonths = (Year(Now) - Year(pdtmDate)) * 12 + (Month(Now) - Month(pdtmDate))
        If Day(Now) < Day(pdtmDate) Then lngMonths = lngMonths -1

...but in order to get the weeks too, you need to recalculate ignoring the months:

        lngWeeks = DateDiff("d", DateAdd("m", pdtmDate, lngMonths), Now) \ 7

That makes sense, thanks.

Once you have the months, the "Years, Months" calculation is along the lines of:

        lngYears = lngMonths \ 12
        lngMonths = lngMonths Mod 12

My function is obviously not very efficient, but I've avoided the Mod operator for years just on principle after learning on these forums that it executes (comparatively) slowly. Do you know if Mod is noticeable slower than my multiplication alternative?

[Ellis Dee]

After a good night's sleep I'm wondering if I can tighten this up by just subtracting dates directly. A quickie proof-of-concept:

?now()-now()
 0 

?now() - date()
 0.58405092592875 

?format(now() - date(),"h:nn")
14:01

[si_the_geek]

With that you would still need to do a similar amount of work to determine which format to use, so you wouldn't gain much.

While there would be a minor speed boost for the initial calculation, the display would probably be slower.

You could possibly re-map things to your previous calculations, but that is cumbersome so I don't think you'd gain much there either - except more complicated code.

My function is obviously not very efficient, but I've avoided the Mod operator for years just on principle after learning on these forums that it executes (comparatively) slowly. Do you know if Mod is noticeable slower than my multiplication alternative?

I don't know, as it has been too long since I regularly worked with VB6... but I suspect that your multiplication alternative would be faster.

[dilettante]

Mod is not slow, certainly no slower than alternative code... the rare case being for whole powers of two where you could use And. Any "slowness" comes from its use of an integer divide.

You need to stop listening to those who mislead you.

How many millions of these intervals are you trying to format anyway?

[Ellis Dee]

How many millions of these intervals are you trying to format anyway?

Three! Not million, I mean three total, as I have three flash drives I use for rolling backups. Obviously efficiency doesn't matter here; I've just always avoided it on principle.



Going further into a subtraction method I see that a datetime value of 0 is represented as #12/30/1899 12:00:00 AM#, which throws a bit of a wrench into my plans. What about the crusades? The renaissance? Microsoft has no sense of history.

Anyway, my initial effort:

Public Function TimeSince1(pdtmDate As Date) As String
    Dim strUnit() As String
    Dim strTerm() As String
    Dim i As Long
    
    strTerm = Split("year month day hour minute second", " ")
    strUnit = Split(Format(Now() - pdtmDate, "yyyy m d h n s"), " ")
    For i = 0 To 5
        Debug.Print Plural(CLng(strUnit(i)), strTerm(i))
    Next
End Function

Which generates:

timesince1 #3/7/2016#
1899 years
12 months
30 days
14 hours
31 minutes
59 seconds

I'm thinking if I then subtract the real NullDate values, I might be getting somewhere.

[si_the_geek]

That certainly has potential for making it shorter... but the months wont be reliable (nor will leap years), as you are effectively resetting it so that it will always count the first month as being 31 days (and the second as 29 I think, then 31 for the third, etc).

[Ellis Dee]

Using the real null date of #12/31/1899 12:00:00 AM# proved unhelpful, but my small brain was able to wrap my head around using #1/1/2000# as a simpler "zero."

Public Function TimeSince(pdtmDate As Date) As String
    Dim strUnit() As String
    Dim strTerm() As String
    Dim strNull() As String
    Dim i As Long
    
    strTerm = Split("year month day hour minute second", " ")
    strUnit = Split(Format(Now() - pdtmDate + #1/1/2000#, "yyyy m d h n s"), " ")
    strNull = Split(Format(#1/1/2000#, "yyyy m d h n s"), " ")
    For i = 0 To 5
        If Val(strUnit(i) - strNull(i)) > 0 Then Exit For
    Next
    Select Case i
        Case 0 To 4: TimeSince = Plural(CLng(strUnit(i) - strNull(i)), strTerm(i)) & ", " & Plural(CLng(strUnit(i + 1) - strNull(i + 1)), strTerm(i + 1)) & " ago"
        Case 5: TimeSince = Plural(CLng(strUnit(i) - strNull(i)), strTerm(i)) & " ago"
        Case 6: TimeSince = "0 seconds ago"
    End Select
End Function

You're right about the month weirdness, and it abandons the concept of weeks entirely, but other than x = (31 - days in current month) days ago this appears to work:

?timesince(Now())
0 seconds ago

?timesince(#3/7/2016 3:18 PM#)
39 seconds ago

?timesince(#3/7/2016 3:13 PM#)
6 minutes, 21 seconds ago

?timesince(#3/4/2016 2:13 PM#)
3 days, 1 hour ago

?timesince(#2/4/2016#)
1 month, 1 day ago <==== WRONG!!!

?timesince(#1/4/2016#)
2 months, 3 days ago

?timesince(#1/17/2015#)
1 year, 1 month ago

[Ellis Dee]

Success!

I added the ability to specify an end date, and removed the " ago" from the return value. It now tells you how much time elapsed between any two date/times, even ones before or on both sides of my arbitrary 1/1/2000 "null date."

The month issue only appeared if Start is in the month before End and Start's day of month is equal to or less than End's. This issue is corrected in the first line of code.

I kind of went nuts optimizing the function for fewest lines of code, to the point that it's no longer particularly readable. But at only 12 lines of code for the core logic, I'm quite pleased.

Public Function TimeBetween(ByVal pdtmStart As Date, ByVal pdtmEnd As Date) As String
    Dim strSplit() As String
    Dim i As Long
    
    If DateDiff("m", pdtmStart, pdtmEnd) = 1 And Day(pdtmStart) <= Day(pdtmEnd) Then pdtmEnd = DateAdd("d", 31 - Day(DateSerial(Year(pdtmStart), Month(pdtmStart) + 1, 0)), pdtmEnd)
    strSplit = Split(Format(pdtmEnd - pdtmStart + #1/1/2000#, "yyyy m d h n s ") & Format(#1/1/2000#, "yyyy m d h n s ") & "year month day hour minute second", " ")
    For i = 0 To 5
        If Val(strSplit(i) - strSplit(i + 6)) > 0 Or i = 5 Then Exit For
    Next
    TimeBetween = Plural(CLng(strSplit(i) - strSplit(i + 6)), strSplit(i + 12))
    If i < 5 Then TimeBetween = TimeBetween & ", " & Plural(CLng(strSplit(i + 1) - strSplit(i + 7)), strSplit(i + 13))
End Function
 
Private Function Plural(plngNumber As Long, pstrSingular As String) As String
    If plngNumber = 1 Then Plural = "1 " & pstrSingular Else Plural = plngNumber & " " & pstrSingular & pstrPlural
End Function

[si_the_geek]

I'm not sure it is quite right, here are two of my tests that don't give the answers I'd expect:

? TimeBetween(#3/2/2014#, #3/1/2014#)
11 months, 30 days

? TimeBetween(#3/2/2014#, #5/1/2014#)
2 months, 0 days

[Ellis Dee]

Well, shoot. Let me take a look.

Note that in your first example, Start is after End. That's not supported.

Your second example looks like an issue, though.

[Ellis Dee]

I was unable to figure out how to account for the root problem. I successfully added an exception for months = 2 to 12, but the problem persisted with years and I couldn't readily solve that one. Which meant I ended up coding special logic for both months/days and years/months, so at this point I may as well do it straight up like in the OP since it's easier to maintain and includes weeks.

I compressed the code from the OP down, but not so much that it's hard to decipher. This is what I'm left with:

Public Const NullDate As Date = #12:00:00 AM#
 
Public Function TimeSince(pdtmDate As Date) As String
    Dim lngYears As Long
    Dim lngMonths As Long
    Dim lngWeeks As Long
    Dim lngDays As Long
    Dim lngHours As Long
    Dim lngMinutes As Long
    Dim lngSeconds As Long
    
    If pdtmDate = NullDate Then
        TimeSince = "Never"
        Exit Function
    End If
    lngSeconds = DateDiff("s", pdtmDate, Now())
    If lngSeconds <= 60 Then ' Seconds
        TimeSince = Plural(lngSeconds, "second")
    ElseIf Reduce(lngMinutes, lngSeconds, 60) <= 60 Then ' Minutes, Seconds
        TimeSince = Plural(lngMinutes, "minute") & ", " & Plural(lngSeconds, "second") & " ago"
    ElseIf Reduce(lngHours, lngMinutes, 60) <= 24 Then ' Hours, Minutes
        TimeSince = Plural(lngHours, "hour") & ", " & Plural(lngMinutes, "minute") & " ago"
    ElseIf Reduce(lngDays, lngHours, 24) <= 7 Then ' Days, Hours
        TimeSince = Plural(lngDays, "day") & ", " & Plural(lngHours, "hour") & " ago"
    ElseIf pdtmDate >= DateAdd("d", -56, Now()) Then ' Weeks, Days
        Reduce lngWeeks, lngDays, 7
        TimeSince = Plural(lngWeeks, "week") & ", " & Plural(lngDays, "day") & " ago"
    Else
        lngMonths = DateDiff("m", pdtmDate, Now())
        If Day(pdtmDate) > Day(Now()) Then lngMonths = lngMonths - 1
        If lngMonths <= 12 Then ' Months, Weeks
            lngWeeks = DateDiff("d", pdtmDate, DateAdd("m", -lngMonths, Now())) \ 7
            TimeSince = Plural(lngMonths, "month") & ", " & Plural(lngWeeks, "week") & " ago"
        ElseIf Reduce(lngYears, lngMonths, 12) < 10 Then ' Years, Months
            TimeSince = Plural(lngYears, "year") & ", " & Plural(lngMonths, "month") & " ago"
        Else ' Years
            TimeSince = Plural(lngYears, "year") & " ago"
        End If
    End If
End Function
 
Private Function Reduce(plngLarge As Long, plngSmall As Long, plngFactor As Long) As Long
    plngLarge = plngSmall \ plngFactor
    plngSmall = plngSmall Mod plngFactor
    Reduce = plngLarge
End Function
 
Private Function Plural(plngNumber As Long, pstrSingular As String, Optional pstrPlural As String = "s") As String
    If plngNumber = 1 Then Plural = "1 " & pstrSingular Else Plural = plngNumber & " " & pstrSingular & pstrPlural
End Function

38 lines of code for the core logic, which makes me sad. I was so happy with the 12-line solution. Too bad I can't figure out how to make it work.

[si_the_geek]

Note that in your first example, Start is after End. That's not supported.

That's fair enough, it's a very easy fix anyway (for others reading later: just swap the dates), I just thought I'd mention it in case you'd had successful tests.

I was unable to figure out how to account for the root problem. I successfully added an exception for months = 2 to 12, but the problem persisted with years and I couldn't readily solve that one. Which meant I ended up coding special logic for both months/days and years/months, so at this point I may as well do it straight up like in the OP since it's easier to maintain and includes weeks.

I haven't thought of a clever fix for the previous code (just the kind of thing you would have tried), so that's probably the way to go.

Keeping code short is nice, but correctness and maintainability are more important.