TheSwamp
Code Red => VB(A) => Topic started by: Bryco on March 11, 2006, 10:38:29 AM
-
Paul wrote/converted a function for comparing singles in vba in cadvault (the address no longer works but this is close to what he wrote). Since the c languages have larger integers than vba I could never get this to work for doubles and am not too sure it works for singles all the time so I don't use it. The reading is a great article and I suspect someone with a bit of math could come up with a usable function.
'Reading http://www.cygnus-software.com/papers/comparingfloats/comparingfloats.htm
'Paul Marshall http://www.cadvault.com/forums/showthread.php?t=15869&page=4&pp=10
Public Function IsEqual(ByVal A As Single, ByVal B As Single, maxUlps As Long) As Boolean
' Make sure maxUlps is non-negative and small enough that the
' default NAN won't compare as equal to anything.
'maxUlps = 5 'I use this
If Not (maxUlps > 0 And maxUlps < 4& * 1024 * 1024) Then
Debug.Print "maxUlps out of range"
Stop
End If
Dim aInt As Long 'originally integer
CopyMemory aInt, A, 4
' Make aInt lexicographically ordered as a twos-complement int
If aInt < 0 Then
aInt = &H80000000 - aInt
End If
' Make bInt lexicographically ordered as a twos-complement int
Dim bInt As Long 'originally integer
CopyMemory bInt, B, 4
If bInt < 0 Then
bInt = &H80000000 - bInt
End If
' We need the range of an unsigned Long but
' there are no unsigned types available in VB
' (other than Byte).
Dim intDiff As Currency
intDiff = Abs(CCur(aInt) - bInt)
Debug.Print A, "Long " & aInt, bInt, intDiff
If intDiff <= maxUlps Then
IsEqual = True
Else
IsEqual = False
End If
End Function
'Forgot this
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal Length As Long)
What I use now works fine but I'm just fishing for better.
Function Rd(Num1 As Variant, Num2 As Variant) As Boolean
Dim dRet As Double
dRet = Num1 - Num2
If Abs(dRet) < 0.00000001 Then Rd = True
End Function
-
am I missing something?
Sub test()
Dim dblOne As Double
Dim dblTwo As Double
Dim intOne As Integer
Dim booTest As Boolean
dblOne = 24.586
dblTwo = 24.586
booTest = SameOrNot(dblOne, dblTwo)
Debug.Print "First test result: " & booTest
dblOne = 24.586
dblTwo = 48.37349
booTest = SameOrNot(dblOne, dblTwo)
Debug.Print "Second test result: " & booTest
dblOne = 24
intOne = 24
booTest = SameOrNot(dblOne, intOne)
Debug.Print "Third test result: " & booTest
End Sub
Public Function SameOrNot(varOne As Variant, varTwo As Variant) As Boolean
If varOne = varTwo Then
SameOrNot = True
End If
End Function
-
Byrco, I basically use the same approach.
Consider these two routines in excel vba:
Public Function VBRoundError(numberOfLoops As Long, Optional Round As Boolean) As Double
Dim i As Long
Dim sum As Double
For i = 0 To numberOfLoops
If Round Then
sum = RoundIt(sum + 0.01, 7)
Else
sum = sum + 0.01
End If
Next
VBRoundError = sum
End Function
Public Function RoundIt(ByVal aNumberToRound As Double, Optional ByVal aDecimalPlaces As Double = 0) As Double
Dim nFactor As Double
Dim nTemp As Double
nFactor = 10 ^ aDecimalPlaces
nTemp = (aNumberToRound * nFactor) + 0.5
RoundIt = Int(CDec(nTemp)) / nFactor
End Function
Once you place these routines into a module you can access the VBRoundError function by typing this "=VBRoundError(99)" into a cell.
If I type these into cells within excel:
=VBRoundError(99) excel displays 1.000000000000000000
=VBRoundError(999) excel displays 9.999999999999830000
=VBRoundError(9999) excel displays 100.000000000014000000
You can clearly see that there is rounding error taking place. This is just the way that VB/A behaves.
If I use this:
=VBRoundError(99,true) excel displays 1.000000000000000000
=VBRoundError(999,true) excel displays 10.000000000000000000
=VBRoundError(9999,true) excel displays 100.000000000000000000
I get nice even values. There really is no way around this because of the way VB/A works.
When working with double or single precision numbers, you should always test using a tolerance or delta value instead of directly comparing two doubles. Here is a routine that I use to test tolerances:
public function ToleranceTest(num1 as double, num2 as double, tolerance as double) as boolean
if abs(num1 - num2) < tolerance then
ToleranceTest = true
else
ToleranceTest = false
endif
end function
-
Maybe I was missing something if it's a tolerance thing then I was off, if you want a comparison between two numbers I wasn't although if you want to check to 8 decimal places you could do it more like
Public Function SameOrNot(varOne As Variant, varTwo As Variant) As Boolean
If Round(varOne, 8) = Round(varTwo, 8) Then
SameOrNot = True
End If
End Function
If numeric comparison between different types like say doubles and integers was a possibility, you could run a check for an integer if one of them is, round to 0 places.
-
Thanks Bob, I have written a polyline join function and without some kind of rounding
you can never get a reliable reading of 0 0r 90 deg or 0 or 0.5* pi.
Stepping through the routine involves 1000's of calls to my sub Rd, it drives me nuts.
Troy, thanks for the post. Your ToleranceTest is virtually the same as mine although it wont accept single or integers so I went for the hungry variants.
The cool part about the article is using Rd or Round doesn't work so well for very large numbers or very small numbers and it comes up with a very good method to facilitate most circumstances.