Public Function Diff2Dates(Interval As String, Date1 As Variant, Date2 As Variant, _ Optional ShowZero As Boolean = False) As Variant 'Author: ? Copyright 2001 Pacific Database Pty Limited ' Graham R Seach MCP MVP gseach@pacificdb.com.au ' Phone: +61 2 9872 9594 Fax: +61 2 9872 9593 ' This code is freeware. Enjoy... ' (*) Amendments suggested by Douglas J. Steele MVP ' 'Description: This function calculates the number of years, ' months, days, hours, minutes and seconds between ' two dates, as elapsed time. ' 'Inputs: Interval: Intervals to be displayed (a string) ' Date1: The lower date (see below) ' Date2: The higher date (see below) ' ShowZero: Boolean to select showing zero elements ' 'Outputs: On error: Null ' On no error: Variant containing the number of years, ' months, days, hours, minutes & seconds between ' the two dates, depending on the display interval ' selected. ' If Date1 is greater than Date2, the result will ' be a negative value. ' The function compensates for the lack of any intervals ' not listed. For example, if Interval lists "m", but ' not "y", the function adds the value of the year ' component to the month component. ' If ShowZero is True, and an output element is zero, it ' is displayed. However, if ShowZero is False or ' omitted, no zero-value elements are displayed. ' For example, with ShowZero = False, Interval = "ym", ' elements = 0 & 1 respectively, the output string ' will be "1 month" - not "0 years 1 month". On Error GoTo Err_Diff2Dates Dim booCalcYears As Boolean Dim booCalcMonths As Boolean Dim booCalcDays As Boolean Dim booCalcHours As Boolean Dim booCalcMinutes As Boolean Dim booCalcSeconds As Boolean Dim booCalcWeeks As Boolean Dim booSwapped As Boolean Dim dtTemp As Date Dim intCounter As Integer Dim lngDiffYears As Long Dim lngDiffMonths As Long Dim lngDiffDays As Long Dim lngDiffHours As Long Dim lngDiffMinutes As Long Dim lngDiffSeconds As Long Dim lngDiffWeeks As Long Dim varTemp As Variant Const INTERVALS As String = "dmyhnsw" 'Check that Interval contains only valid characters Interval = LCase$(Interval) For intCounter = 1 To Len(Interval) If InStr(1, INTERVALS, Mid$(Interval, intCounter, 1)) = 0 Then Exit Function End If Next intCounter 'Check that valid dates have been entered If IsNull(Date1) Then Exit Function If IsNull(Date2) Then Exit Function If Not (IsDate(Date1)) Then Exit Function If Not (IsDate(Date2)) Then Exit Function 'If necessary, swap the dates, to ensure that 'Date1 is lower than Date2 If Date1 > Date2 Then dtTemp = Date1 Date1 = Date2 Date2 = dtTemp booSwapped = True End If Diff2Dates = Null varTemp = Null 'What intervals are supplied booCalcYears = (InStr(1, Interval, "y") > 0) booCalcMonths = (InStr(1, Interval, "m") > 0) booCalcDays = (InStr(1, Interval, "d") > 0) booCalcHours = (InStr(1, Interval, "h") > 0) booCalcMinutes = (InStr(1, Interval, "n") > 0) booCalcSeconds = (InStr(1, Interval, "s") > 0) booCalcWeeks = (InStr(1, Interval, "w") > 0) 'Get the cumulative differences If booCalcYears Then lngDiffYears = Abs(DateDiff("yyyy", Date1, Date2)) - _ IIf(Format$(Date1, "mmddhhnnss") <= Format$(Date2, "mmddhhnnss"), 0, 1) Date1 = DateAdd("yyyy", lngDiffYears, Date1) End If If booCalcMonths Then lngDiffMonths = Abs(DateDiff("m", Date1, Date2)) - _ IIf(Format$(Date1, "ddhhnnss") <= Format$(Date2, "ddhhnnss"), 0, 1) Date1 = DateAdd("m", lngDiffMonths, Date1) End If If booCalcWeeks Then lngDiffWeeks = Abs(DateDiff("w", Date1, Date2)) - _ IIf(Format$(Date1, "hhnnss") <= Format$(Date2, "hhnnss"), 0, 1) Date1 = DateAdd("ww", lngDiffWeeks, Date1) End If If booCalcDays Then lngDiffDays = Abs(DateDiff("d", Date1, Date2)) - _ IIf(Format$(Date1, "hhnnss") <= Format$(Date2, "hhnnss"), 0, 1) Date1 = DateAdd("d", lngDiffDays, Date1) End If If booCalcHours Then lngDiffHours = Abs(DateDiff("h", Date1, Date2)) - _ IIf(Format$(Date1, "nnss") <= Format$(Date2, "nnss"), 0, 1) Date1 = DateAdd("h", lngDiffHours, Date1) End If If booCalcMinutes Then lngDiffMinutes = Abs(DateDiff("n", Date1, Date2)) - _ IIf(Format$(Date1, "ss") <= Format$(Date2, "ss"), 0, 1) Date1 = DateAdd("n", lngDiffMinutes, Date1) End If If booCalcSeconds Then lngDiffSeconds = Abs(DateDiff("s", Date1, Date2)) Date1 = DateAdd("s", lngDiffSeconds, Date1) End If If booCalcYears And (lngDiffYears > 0 Or ShowZero) Then varTemp = lngDiffYears & IIf(lngDiffYears <> 1, " years", " year") End If If booCalcMonths And (lngDiffMonths > 0 Or ShowZero) Then If booCalcMonths Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffMonths & IIf(lngDiffMonths <> 1, " months", " month") End If End If If booCalcWeeks And (lngDiffWeeks > 0 Or ShowZero) Then If booCalcWeeks Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffWeeks & IIf(lngDiffWeeks <> 1, " weeks", " week") End If End If If booCalcDays And (lngDiffDays > 0 Or ShowZero) Then If booCalcDays Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffDays & IIf(lngDiffDays <> 1, " days", " day") End If End If If booCalcHours And (lngDiffHours > 0 Or ShowZero) Then If booCalcHours Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffHours & IIf(lngDiffHours <> 1, " hours", " hour") End If End If If booCalcMinutes And (lngDiffMinutes > 0 Or ShowZero) Then If booCalcMinutes Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffMinutes & IIf(lngDiffMinutes <> 1, " minutes", " minute") End If End If If booCalcSeconds And (lngDiffSeconds > 0 Or ShowZero) Then If booCalcSeconds Then varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _ lngDiffSeconds & IIf(lngDiffSeconds <> 1, " seconds", " second") End If End If If booSwapped Then varTemp = "-" & varTemp End If Diff2Dates = Trim$(varTemp) End_Diff2Dates: Exit Function Err_Diff2Dates: Resume End_Diff2Dates End Function
------------------------------------------------------
example:
diff2dates("ymd",#10/4/1923#,#5/25/2021#,True) result: 97 years 7 months 21 days Regards,
Lou
_._,_._,_
Groups.io Links:
You receive all messages sent to this group.
View/Reply Online (#116612) | Reply To Group | Reply To Sender | Mute This Topic | New Topic
Your Subscription | Contact Group Owner | Unsubscribe [sugeng.panjalu.access@blogger.com]
_._,_._,_
Tidak ada komentar:
Posting Komentar