Совет:
'Примечание:
'если в качестве входного параметра указано (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
--------------------------------------------------------------------------------
Матющенко Георгий
|