mx
' Accepts: a variant value
' Purpose: converts multiplace decimal numbers
' Returns: a number rounded to d decimal places
' or a zero if the value it was called for was null
' If d is negative or null d is set to 0 and the function is like Int()
' In any case d is set to Int(d)!
' Author: Marcus O. M. Grabe, CIS 100120,1405
' Please send a message, if you like it or if you have any suggestions.
Function Round(n, d)
On Error Resume Next
If IsNull(n) Or IsNull(d) Then
Round = 0
Else
If d < 0 Then
d = 0
Else
d = Int(d)
End If
Round = CLng(n * (10 ^ d)) / (10 ^ d)
End If
End Function
Public Function RoundSignificant(varValue As Variant, intNumSignificantDigits As Integer) As String
Dim strPrefix As String
Dim dblFactor As Double
Dim dblABSofValue As Double
Dim strFormatedValue As String
Dim lngPos As Long
Dim bolDecimalPoint As Boolean
Dim strChr As String
Dim lngNumOfDigits As Long
' Check for a prefix ('>' or '<'). If there is one,
' strip it off for now.
If left(varValue, 1) = ">" Or left(varValue, 1) < "<" Then
strPrefix = left(varValue, 1)
varValue = Val(Mid(varValue, 2))
Else
strPrefix = ""
End If
' Check for null
varValue = Nz(varValue, 0)
' If value of zero, return "N/A"
If varValue = 0 Then
RoundSignificant = "N/A"
Else
' Get the factor
dblFactor = 10 ^ Int(Log(Abs(varValue)) / Log(10) - intNumSignificantDigits + 1)
' Based on the factor, get an absolute value that's rounded.
dblABSofValue = Int(Abs(varValue) / dblFactor + 0.5) * dblFactor
' Format the value as a string.
strFormatedValue = Format((IIf(varValue >= 0, 1, -1) * dblABSofValue), "#0.00000000000000000000")
' Do we have a decimal point?
If InStr(strFormatedValue, ".") > 0 Then
' If so, chop off all zeros on the right
While right(strFormatedValue, 1) = "0"
strFormatedValue = left(strFormatedValue, Len(strFormatedValue) - 1)
Wend
End If
' Scan for the number of digits in the string
For lngPos = 1 To Len(strFormatedValue)
strChr = Mid(strFormatedValue, lngPos, 1)
If strChr > "0" And strChr <= "9" Then
lngNumOfDigits = lngNumOfDigits + 1
End If
If strChr = "." Then
bolDecimalPoint = True
End If
Next
' Is the number of digits found less then the significance required?
If lngNumOfDigits < intNumSignificantDigits Then
' If so and we have decimal point, add some zeros
If bolDecimalPoint = True Then
strFormatedValue = strFormatedValue & String(intNumSignificantDigits - lngNumOfDigits, "0")
End If
End If
' Do we have anything to the right of the decimal?
' If not, remove the decimal point
If right(strFormatedValue, 1) = "." Then
strFormatedValue = left(strFormatedValue, Len(strFormatedValue) - 1)
End If
' Add the prefix back in if we have one
If strPrefix <> "" Then
RoundSignificant = strPrefix & strFormatedValue
Else
RoundSignificant = strFormatedValue
End If
End If
End Function
Public Function RoundSignificantCurrency( _
ByVal curValue As Currency, _
ByVal bytSignificantDigits As Byte, _
Optional ByVal booInteger As Boolean) _
As Currency
' Rounds curValue to bytSignificantDigits digits.
'
' Performs no rounding if bytSignificantDigits is zero.
' Rounds to integer if booInteger is True.
'
' Rounds correctly curValue until max/min value of currency type multiplied with
' 10 raised to the power of (the number of digits of the index of curValue) minus
' bytSignificantDigits.
' This equals roughly +/-922 * 10 ^ 12 for any value of bytSignificantDigits.
'
' Requires:
' Function Log10.
'
' 2001-10-19. Cactus Data ApS, CPH.
' 2002-04-02. Added CDec() for correcting bit errors of reals.
' 2007-04-18. Int replaced with Fix to round negative values correctly.
' Parameter booInteger made Optional.
Dim dblTmp As Double
Dim dblFactor As Double
Dim dblPower As Double
' No special error handling.
On Error Resume Next
If bytSignificantDigits = 0 Or curValue = 0 Then
' Nothing to do.
Else
dblPower = Int(Log10(Abs(curValue))) + 1 - bytSignificantDigits
If booInteger = True Then
' No decimals.
If dblPower < 0 Then
dblPower = 0
End If
End If
dblFactor = 10 ^ dblPower
dblTmp = curValue / dblFactor
dblTmp = Fix(dblTmp + Sgn(dblTmp) / 2)
' Apply CDec() to correct for possible bit error when multiplying reals.
curValue = CDec(dblTmp * dblFactor)
End If
RoundSignificantCurrency = curValue
End Function
Public Function Log10( _
ByVal dblValue As Double) _
As Double
' Returns Log 10 of input dblValue.
' No error handling as this should be handled
' outside this function.
'
' Example:
'
' If dblMyValue > 0 then
' dblLogMyValue = Log10(dblMyValue)
' Else
' ' Do something else ...
' End If
Log10 = Log(dblValue) / Log(10)
End Function
Title | # Comments | Views | Activity |
---|---|---|---|
need to save the complete html of a webpage using ie using vba access | 10 | 43 | |
Export code - file path based on either at Home or Work | 5 | 21 | |
MS Access single form simultaneous memo field edit by several users | 7 | 19 | |
Best RAID for a BDD Oracle | 4 | 12 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
10 Experts available now in Live!