Определие первого дня и последнего дней недели, месяца, квартала, полугодия, года. Вычисление возраста, порядкового номера дня в году. Проверка года на "високосность" и т.д. и т.п. Всего более 10 функций.
'Примечание: 'если в качестве входного параметра указано (Optional dteDate As Date), 'то вызов функции можно осуществлять как НазваниеФункции() '- то есть можно оставлять пустые скобки. 'Например: 'MsgBox FirstOfQuarter()
' определение первого дня месяца Function FirstOfMonth(Optional dteDate As Date) As Date 'если параметр dteDate = 0 то для вычисления берется текущая дата If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfMonth = DateSerial(Year(dteDate), Month(dteDate), 1) MsgBox "Первый день месяца - " & FirstOfMonth End Function Function LastOfMonth(Optional dteDate As Date) As Date 'если параметр dteDate = 0 то для вычисления берется текущая дата If CLng(dteDate) = 0 Then dteDate = Date End If 'Ищется первый день следующего месяца, и вычитается один день LastOfMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) - 1 MsgBox "Первый день месяца - " & LastOfMonth End Function ' определение первого дня месяца предыдущего указанному Function FirstOfPreviousMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate) - 1, 1) MsgBox "Первый день предыдущего месяца - " & FirstOfPreviousMonth End Function ' определение последнего дня месяца предыдущего указанному Function LastOfPreviousMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate), 0) MsgBox "Последний день предыдущего месяца - " & LastOfPreviousMonth End Function
' определение первого дня месяца следующего за указанным Function FirstOfNextMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) MsgBox "Первый день следующего месяца - " & FirstOfNextMonth End Function ' определение последнего дня месяца следующего за указанным Function LastOfNextMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 2, 0) MsgBox "Последний день следующего месяца - " & LastOfNextMonth End Function 'Определение первого дня текущего квартала Function FirstOfQuarter(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfQuarter = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 3) * 3 + 1, 1) MsgBox "Первый день текущего квартала - " & FirstOfQuarter End Function 'Определение последнего дня текущего квартала Function LastOfQuarter(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfQuarter = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 3) * 3 + 4, 0) MsgBox "Последний день текущего квартала - " & LastOfQuarter End Function Function FirstOfPolugod(Optional dteDate As Date) As Date 'Dim dteDate As Date 'dteDate = #12/15/02# If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfPolugod = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 6) * 6 + 1, 1) MsgBox "Первый день текущего полугодия - " & FirstOfPolugod End Function Function LastOfPolugod(Optional dteDate As Date) As Date 'Dim dteDate As Date 'dteDate = #12/15/02# If CLng(dteDate) = 0 Then dteDate = Date End If LastOfPolugod = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 6) * 6 + 7, 0) MsgBox "Первый день текущего полугодия - " & LastOfPolugod End Function ' Первый день недели Function StartOfWeek(Optional D As Variant) As Variant ' Dim FirstWeekday As Integer FirstWeekday = 2 If IsMissing(D) Then 'Первый день недели - понедельник D = Date StartOfWeek = D - WeekDay(D) + 2 Else StartOfWeek = D - WeekDay(D, FirstWeekday) + 1 End If MsgBox "Первый день недели - " & StartOfWeek End Function ' Последний день недели Function EndOfWeek(Optional D As Variant) As Variant ' Dim FirstWeekday As Integer FirstWeekday = 2 If IsMissing(D) Then 'Последний день недели - воскресенье D = Date EndOfWeek = D - WeekDay(D) + 8 Else EndOfWeek = D - WeekDay(D, FirstWeekday) + 7 End If MsgBox "Последний день недели - " & EndOfWeek End Function Function LeapYear(YYYY As Integer) As Integer 'Функция возвращает -1, если указанный входной параметр (год) является високосным 'Пример: MsgBox LeapYear(1996) LeapYear = YYYY Mod 4 = 0 And (YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0) If LeapYear = -1 Then MsgBox "Високосный" Else MsgBox "Простой год" End If End Function Function LeapYear2(YYYY As Integer) As Integer 'Функция возвращает -1, если указанный входной параметр (год) является високосным 'Пример: MsgBox LeapYear(1996) LeapYear2 = Month(DateSerial(YYYY, 2, 29)) = 2 If LeapYear2 = -1 Then MsgBox "Високосный" Else MsgBox "Простой год" End If End Function Function IsLeapYear(DateIn As Date) As Boolean 'Функция возвращает True, если год в указанной дате является високосным 'Проверка: MsgBox IsLeapYear("01/01/00") If IsDate("29/02/" & Format(DateIn, "yyyy")) = True Then IsLeapYear = True MsgBox "Високосный" Else MsgBox "Простой год" End If End Function ' Определение номера дня недели в году Function DayOfYear(Optional dteDate As Date) As Long If CLng(dteDate) = 0 Then dteDate = Date End If DayOfYear = Abs(DateDiff("d", dteDate, DateSerial(Year(dteDate) - 1, 12, 31))) MsgBox "День № " & DayOfYear & " в году" End Function ' Рабочий день или нет Function IsWorkday(Optional dteDate As Date) As Boolean If CLng(dteDate) = 0 Then dteDate = Date End If Select Case WeekDay(dteDate) Case vbMonday To vbFriday IsWorkday = True MsgBox "Рабочий день" Case Else IsWorkday = False MsgBox "Выходной" End Select End Function 'Функция определения полных лет со дня рождения Function CalcAge(dteBirthdate As Date) As Long 'В качестве параметра dteBirthdate необходимо задать дату рождения 'Пример: MsgBox CalcAge("09/03/75") Dim lngAge As Long If Not IsDate(dteBirthdate) Then dteBirthdate = Date End If 'Проверить, чтобы в качестве входного параметра не была задана дата в будущем If dteBirthdate > Date Then dteBirthdate = Date End If 'Подсчет разницы в годах между текущей датой и датой рождения lngAge = DateDiff("yyyy", dteBirthdate, Date) 'Вычитается один год, если в этом году дня рождения еще не было If DateSerial(Year(Date), Month(dteBirthdate), Day(dteBirthdate)) > Date Then lngAge = lngAge - 1 End If CalcAge = lngAge MsgBox "Итого полных лет - " & CalcAge End Function 'Функция возвращает последний рабочий день в текущем месяце (Понедельник-Пятница) Function LastBusDay(D As Variant) As Variant 'Пример: MsgBox LastBusDay(Date) Dim D2 As Variant If VarType(D) <> 7 Then LastBusDay = Null Else D2 = DateSerial(Year(D), Month(D) + 1, 0) Do While WeekDay(D2) = 1 Or WeekDay(D2) = 7 D2 = D2 - 1 Loop LastBusDay = D2 End If MsgBox "Последний рабочий день - " & LastBusDay End Function