by Cyrus Lacaba aka Biohazard of Las Pi?as (6 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 17th July 2009
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Better version of Compute Duration (Can be used in MS Access too)
VBcoders
'Function Rounding of Number by Cyrus - Biohazard
Public Function RoundNo(fltValue As Variant, intDecimalPlaces As Integer) As Double
On Error GoTo RoundNoErr
Dim strValue$, strValue2$, intstrValuelength%, intNextValue%, strValuetoAdd$, intValLength%, ix%
strValue$ = CStr(Val(fltValue))
intValLength% = intDecimalPlaces + 2
If intDecimalPlaces = 0 Then
Dim intFixValue%
intFixValue% = Fix(Val(fltValue))
strValue2$ = Mid(strValue$, 3)
If Val(Mid(strValue2$, 1, 1)) >= 5 Then
RoundNo = intFixValue% + 1
Else
RoundNo = intFixValue%
End If
Exit Function
ElseIf (intValLength% = Len(strValue$)) Or _
(strValue$ = "0.0" Or strValue$ = "0") Or _
(intDecimalPlaces < 0) Then
strValue2$ = strValue$
GoTo ReturnTheSameValue
End If
strValue2$ = Mid(strValue$, 1, intValLength%)
intNextValue% = Val(Mid(strValue$, intValLength% + 1, 1))
If intNextValue% >= 5 Then
intstrValuelength% = Len(strValue2$)
strValuetoAdd$ = "0."
For ix = 3 To intstrValuelength%
If ix = intstrValuelength% Then Exit For
strValuetoAdd$ = strValuetoAdd$ & "0"
Next
strValuetoAdd$ = strValuetoAdd$ & "1"
RoundNo = CDbl(strValue2$) + CDbl(strValuetoAdd$)
Else
GoTo ReturnTheSameValue
End If
Exit Function
ReturnTheSameValue:
RoundNo = CDbl(strValue2$)
Exit Function
RoundNoErr:
RoundNo = 0
End Function
Public Function GetPeriodDesired(strValue$, lngToGet As Long, Optional blnLeap As Boolean = True) As Variant
Dim intMonth%, intDays%, varResult As Variant
'strValue$ = CStr(varValue)
If InStr(1, strValue$, ".") > 0 Then
intMonth% = Val(Mid(strValue$, 1, InStr(1, strValue$, ".") - 1))
intDays% = Val(Mid(strValue$, InStr(1, strValue$, ".") + 1))
Else
intMonth% = Val(strValue$)
End If
'Possible Result
Select Case lngToGet
Case 1 'Y - Year(s) Only
varResult = Fix(intMonth% / 12)
Case 2 'Y.M - Year(s).Month(s) Only
varResult = Fix(intMonth% / 12) & "." & intMonth% - (Fix(intMonth% / 12) * 12)
Case 3 'M - Month(s) Only
varResult = intMonth%
Case 4 'M.D - Month(s).Day(s) Only
varResult = intMonth% & "." & intDays%
Case 5 'D - Day(s) Only
varResult = Val(IIf(blnLeap = True, RoundNo((intMonth% / 12), 0) * 366, RoundNo((intMonth% / 12), 0) * 365)) + intDays%
End Select
GetPeriodDesired = varResult
End Function
'Brought to you by Cyrus aka Biohazard
Public Function GetActualPeriodDiffByCyAccurate(dStart As Date, dEnd As Date, lngToGet As Long, Optional blnLeap As Boolean = True) As String
Dim intNoOfDays%, intDaysPerMonthoftheYear%(12), _
intDStartMonth%, intDEndMonth%, intYearDiff%, _
dblTotalMonthsNDays#, _
ix%, intDaysRemaining%, _
intMontConsumed%
If (IsNull(dStart) Or IsNull(dEnd)) Or dStart > dEnd Then
GetActualPeriodDiffByCyAccurate = "0.0"
Exit Function
End If
'Tracing of TNoDays in Year of dStart
intDaysPerMonthoftheYear%(1) = 31
intDaysPerMonthoftheYear%(2) = IIf(DateDiff("d", CDate("1/1/" & Year(dStart)), CDate("12/31/" & Year(dStart))) = 365, 29, 28)
intDaysPerMonthoftheYear%(3) = 31
intDaysPerMonthoftheYear%(4) = 30
intDaysPerMonthoftheYear%(5) = 31
intDaysPerMonthoftheYear%(6) = 30
intDaysPerMonthoftheYear%(7) = 31
intDaysPerMonthoftheYear%(8) = 31
intDaysPerMonthoftheYear%(9) = 30
intDaysPerMonthoftheYear%(10) = 31
intDaysPerMonthoftheYear%(11) = 30
intDaysPerMonthoftheYear%(12) = 31
intDStartMonth% = Month(dStart)
intDEndMonth% = Month(dEnd)
intYearDiff% = DateDiff("yyyy", dStart, dEnd)
If intYearDiff% > 0 Then
'Recursive
For ix% = 0 To intYearDiff%
If ix% <> intYearDiff% Then
dblTotalMonthsNDays# = dblTotalMonthsNDays# + Val(GetActualPeriodDiffByCyAccurate(dStart, CDate("12/31/" & Year(dStart) + ix%), 4))
Else
Dim strLastNumValue$, strGenVal$
strGenVal$ = GetActualPeriodDiffByCyAccurate(CDate("1/1/" & Year(dEnd)), dEnd, 4)
strLastNumValue$ = strGenVal$
dblTotalMonthsNDays# = dblTotalMonthsNDays# + CDbl(strGenVal$)
If Len(strLastNumValue$) = 4 Then
strLastNumValue$ = Mid(strLastNumValue$, Len(strLastNumValue$))
End If
End If
Next
GetActualPeriodDiffByCyAccurate = GetPeriodDesired(CStr(dblTotalMonthsNDays#), lngToGet, blnLeap) & IIf(strLastNumValue$ = "0", "0", "")
ElseIf intYearDiff% = 0 Then
If intDStartMonth% = intDEndMonth% Then
intNoOfDays% = DateDiff("d", dStart, dEnd) + 1
If intNoOfDays% = intDaysPerMonthoftheYear%(intDStartMonth%) Then
GetActualPeriodDiffByCyAccurate = GetPeriodDesired("1", lngToGet, blnLeap)
Else
GetActualPeriodDiffByCyAccurate = GetPeriodDesired(intMontConsumed% & "." & (DateDiff("d", dStart, dEnd + 1)), lngToGet, blnLeap)
End If
Exit Function
ElseIf intDStartMonth% <> intDEndMonth% Then
intNoOfDays% = DateDiff("d", dStart, dEnd) + 1
For ix% = intDStartMonth% To intDEndMonth%
If intNoOfDays% >= intDaysPerMonthoftheYear%(ix%) Then
intMontConsumed% = intMontConsumed% + 1
intNoOfDays% = intNoOfDays% - intDaysPerMonthoftheYear%(ix%)
Else
intDaysRemaining% = intNoOfDays%
End If
Next
GetActualPeriodDiffByCyAccurate = GetPeriodDesired(CStr(intMontConsumed%) & "." & CStr(intDaysRemaining%), lngToGet, blnLeap)
End If
End If
End Function
No comments have been posted about Better version of Compute Duration (Can be used in MS Access too). Why not be the first to post a comment about Better version of Compute Duration (Can be used in MS Access too).
