VBA, MS Access MS Access в примерах

Дата - Возраст на конкретную или текущую дату с точностью до месяца и дня (текстом)

Public Function AgeByBirthDay(bdDate As Variant, Optional forDate As Variant = Null) As String
'es 04.03.2019
'Возвращает возраст на текущую дату (или на конкретную дату) с точностью до месяца и дня (текстом)
' При ошибке вернёт текст с её номером ...
'--------------------------------------------------------------------------
'Аргументы:
'   bdDate      -  Дата Рождения
'   forDate     -  Дата на которую рассчитать (по умолчанию = сегодня)
'--------------------------------------------------------------------------
' ?AgeByBirthDay (#12/12/1476#)
' Вернёт: Лет: 542 Мес: 2 Дней: 20
'--------------------------------------------------------------------------
Dim dLastBDay As Date
Dim iYears%, iMonthes%, iDays%, i%

On Error GoTo AgeByBirthDayErr

'Проверяем аргументы
    If IsNull(forDate) Then forDate = Date

'Разница в годах между датой рождения и датой на которую
    iYears = DateDiff("yyyy", bdDate, forDate)

    dLastBDay = DateSerial(Year(forDate), Month(bdDate), Day(bdDate))

'Вычитается один год, если в этом году дня рождения еще не было
    If dLastBDay > forDate Then
        iYears = iYears - 1
    End If
    
    i = Year(bdDate) + iYears
    dLastBDay = DateSerial(i, Month(bdDate), Day(bdDate))
    'Debug.Print "LastBDay: " & dLastBDay

'Меяцев
    iMonthes = DateDiff("m", dLastBDay, forDate)
    If Day(bdDate) > Day(forDate) Then
        iMonthes = iMonthes - 1
    End If

'Дней
    dLastBDay = DateSerial(i, Month(bdDate) + iMonthes, Day(bdDate))
    iDays = DateDiff("d", dLastBDay, forDate)

'Результат:
    AgeByBirthDay = "Лет: " & iYears
    AgeByBirthDay = AgeByBirthDay & " Мес: " & iMonthes
    AgeByBirthDay = AgeByBirthDay & " Дней: " & iDays
    
AgeByBirthDayBye:
    Exit Function

AgeByBirthDayErr:
    AgeByBirthDay = "Err!:" & Err.Number
    'MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
        "in Function: AgeByBirthDay ", vbCritical, "Error in Application"

    Err.Clear
    Resume AgeByBirthDayBye
End Function
Назад ToTop
L.E. 06.03.2019
Рейтинг@Mail.ru