CodeItBetter Programming Another VB Programming Blog

'Date & Time - How to get exact age by accepting  the date of birth (in four ways)
'Method 1:

'This function which accepts date of birth from and returns age in exact years, months and days

Public Function ExactAge(BirthDate As Variant) As String
    Dim yer As Integer, mon As Integer, d As Integer
    Dim dt As Date
    Dim sAns As String
    If Not IsDate(BirthDate) Then Exit Function
    dt = CDate(BirthDate)
    If dt > Now Then Exit Function
    yer = Year(dt)
    mon = Month(dt)
    d = Day(dt)
    yer = Year(Date) - yer
    mon = Month(Date) - mon
    d = Day(Date) - d
    If Sgn(d) = -1 Then
        d = 30 - Abs(d)
        mon = mon - 1
    End If
    If Sgn(mon) = -1 Then
        mon = 12 - Abs(mon)
        yer = yer - 1
    End If
    sAns = yer & " year(s) " & mon & " month(s) " & d & " day(s) old."
    ExactAge = sAns
End Function
 
'Method 2:

Const ERR_INVALID_DATE = 20000
Const ERR_INVALID_DATE_MSG = "Date Required"
 
'PURPOSE: Calculates a person's age

'PARAMETERS:

'BirthDate: the person's birthdate, in date or string format
'RelativeTo (Optional) the "as of" date.  If not specified, the
'current date is used

'RETURNS: The person's age as of the date specified in
'RelativeTo, or as of the current date if RelativeTo isn't specified.

Public Function Age(BirthDate As Variant, Optional RelativeTo As Variant) As Integer
    Dim dBDate As Date, dRelDate As Date
    Dim bSubtractOne As Boolean
    Dim iAns As Integer
    If IsMissing(RelativeTo) Then
        RelativeTo = Now
    ElseIf Not IsDate(RelativeTo) Then
        Err.Raise ERR_INVALID_DATE, , ERR_INVALID_DATE_MSG
    End If
    If Not IsDate(BirthDate) Then Err.Raise ERR_INVALID_DATE, , ERR_INVALID_DATE_MSG
    dBDate = CDate(BirthDate)
    dRelDate = CDate(RelativeTo)
    iAns = Year(dRelDate) - Year(dBDate)
    If Month(dBDate) <> Month(dRelDate) Then
        bSubtractOne = Month(dBDate) > Month(dRelDate)
    Else
        bSubtractOne = Day(dBDate) > Day(dRelDate)
    End If
    If bSubtractOne Then iAns = iAns - 1
    Age = iAns
End Function
 
'Method 3:

' Calculates age in years from a given date to today's date.
Function Age(varBirthDate As Variant) As Integer
    Dim varAge As Variant
    If Not IsDate(varBirthDate) Then Exit Function
    varAge = DateDiff("yyyy", varBirthDate, Now)
    If Date < DateSerial(Year(Now), Month(varBirthDate), Day(varBirthDate)) Then
        varAge = varAge - 1
    End If
    Age = CInt(varAge)
End Function
 
'Method 4:

' Calculates age in years from a given date to today's date.
Public Function ReturnAge(ByVal varDOB As Date) As String
     If IsDate(varDOB) Then
          ReturnAge = DateDiff("yyyy", [varDOB], Now()) + Int(Format(Now(), "mmdd") < _
              Format([varDOB], "mmdd"))
     End If
End Function