I am trying to round up numbers in a legacy application which I had coded in VB6 to obtain the following outcomes:
2.53 should be 2.60
2.55 should be 2.60
2.56 should be 2.60
2.50 should remain 2.50
2.501 should be 2.50
2.505 should be 2.60
I have tried to use the suggested User-Defined Rounding functions by Microsoft
http://support.microsoft.com/kb/196652/en-gb
The closest I arrived to is the Asymup function
Function AsymUp(ByVal X As Double, _
Optional ByVal Factor As Double = 1) As Double
Dim Temp As Double
Temp = Int(X * Factor)
AsymUp = (Temp + IIf(X = Temp, 0, 1)) / Factor
End Function
I am testing this procedure by calling the function as follows:
Text1.Text = AsymUp(Val(Text1.Text), 10)
But this is not producing the desired results because 2.60 for example becomes 2.7 when I want it to remain 2.6. Strangely enough 2.0 also becomes 2.1, implying that the function is not working well.
How can I correct this to acheive the desired results
Private Function AsymUp(ByVal D As Double, Optional Precision As Double = 1) As Double
Precision = CDbl("1" & String$(Precision, 48))
D = D * Precision
If Int(D) <> D Then
AsymUp = (Int(D) + 1) / Precision
Else
AsymUp = D / Precision
End If
End Function
Visual Basic will always automatically truncate trailing zeros from Double and Single data types. Therefore, unless a function is designed to pass the number back as a string, along with the extra zero(s) appended, it will be impossible to retain trailing zeros of a particular precision.
Bonus tip: The IIf function should not be used where performance is of concern, as both the falsepart and truthpart parameters are always evaluated, regardless of the arguments passed to them.
String manipulation method (retains zeros):
Private Function AsymUp(ByVal D As Double, Optional Precision As Double = 1) As String
Dim P As Double, Z As Long
P = CDbl("1" & String$(Precision, 48))
D = D * P
If Int(D) <> D Then
D = (Int(D) + 1) / P
Else
D = D / P
End If
AsymUp = CStr(D)
Z = Precision - (Len(AsymUp) - InStr(AsymUp, "."))
If Z > 0 Then AsymUp = AsymUp & String$(Z, 48)
End Function
This will obviously not be as efficient to run as my other answer, but it's the only way to keep any trailing zeros intact.
Please note that the function will always return the number as a string. You may need to convert the string back to a decimal number to continue using the number with additional mathematics in your program.
I've resolved the issue using the following code:
Private Sub Command1_Click()
roundnumber = Val(Text1.Text)
Text1.Text = Round(roundnumber, 2)
Text1.Text = AsymUp(Val(Text1.Text), 10)
End Sub
Function AsymUp(ByVal X As Double, _
Optional ByVal Factor As Double = 1) As Double
Dim Temp As Double
Temp = Int(X * Factor)
AsymUp = (Temp + IIf((X * Factor) = Temp, 0, 1)) / Factor
End Function
This is what I was after not precision to 10dp as suggested in this post.
Related
All,
I'm intermediate for VB6. I want to get remainder from divided two doubles. I used ,
Dim a As Double, b As Double, result As Double
b = 8333.33
a = 58333.31
result = a - (b * Fix(a / b))
result should be 0. But it is not.
a/b =7 and no remain. So Fix(a / b) should be 7. But Fix(a / b)=6, Why?
If you use this as a workaround I think you will get the result you expect:
Dim a As Double, b As Double, intermediate As Double, fixed1 As Double, fixed2 As Double
b = 8333.33
a = 58333.31
intermediate = a / b
fixed1 = Fix(intermediate)
fixed2 = Fix(a / b)
Debug.Print intermediate ' 7
Debug.Print fixed1 ' 7
Debug.Print fixed2 ' 6
Documentation for Fix says:
Int, Fix functions
Returns the integer portion of a number.
... Remarks Both Int and Fix remove the fractional part of number and
return the resulting integer value.
(that is from VBA docs but should be the same for VB6).
Apparently when VB evaluates a / b within the context of the function call it results in a floating point value very slightly < 7.
BTW, another trick to get it working - depending on the floating point numbers you need to work with - is to use Currency instead of Double
Dim a As Currency, b As Currency
b = 8333.33
a = 58333.31
Debug.Print Fix(a / b) ' Returns 7
Debug.Print a - (b * Fix(a / b)) ' Returns 0
In VB6, I am trying to convert a number to binary but when the number has 10 digits i am always getting an Overflow error.
What is the data type where i can store a trillion number?
This is the code which is working when the number has less that 10 digits.
Public Function DecimalToBinary(DecimalNum As Double) As _
String
Dim tmp As String
Dim n As Double
n = DecimalNum
tmp = Trim(Str(n Mod 2))
n = n \ 2
Do While n <> 0
tmp = Trim(Str(n Mod 2)) & tmp
n = n \ 2
Loop
DecimalToBinary = tmp
End Function
One of the problems you will encounter is that the Mod operator will not work with values larger than a Long (2,147,483,647). You can rewrite a Mod function as described in this answer: VBA equivalent to Excel's mod function:
' Divide the number by 2.
' Get the integer quotient for the next iteration.
' Get the remainder for the binary digit.
' Repeat the steps until the quotient is equal to 0.
Public Function DecimalToBinary(DecimalNum As Double) As String
Dim tmp As String
Dim n As Double
n = DecimalNum
Do While n <> 0
tmp = Remainder(n, 2) & tmp
n = Int(n / 2)
Loop
DecimalToBinary = tmp
End Function
Function Remainder(Dividend As Variant, Divisor As Variant) As Variant
Remainder = Dividend - Divisor * Int(Dividend / Divisor)
End Function
You can also rewrite your function to avoid Mod altogether:
Public Function DecimalToBinary2(DecimalNum As Double) As String
Dim tmp As String
Dim n As Double
Dim iCounter As Integer
Dim iBits As Integer
Dim dblMaxSize As Double
n = DecimalNum
iBits = 1
dblMaxSize = 1
' Get number of bits
Do While dblMaxSize <= n
dblMaxSize = dblMaxSize * 2
iBits = iBits + 1
Loop
' Move back down one bit
dblMaxSize = dblMaxSize / 2
iBits = iBits - 1
' Work back down bit by bit
For iCounter = iBits To 1 Step -1
If n - dblMaxSize >= 0 Then
tmp = tmp & "1"
n = n - dblMaxSize
Else
' This bit is too large
tmp = tmp & "0"
End If
dblMaxSize = dblMaxSize / 2
Next
DecimalToBinary2 = tmp
End Function
This function finds the bit that is larger than your number and works back down, bit by bit, figuring out if the value for each bit can be subtracted from your number. It's a pretty basic approach but it does the job.
For both functions, if you want to have your binary string in groups of 8 bits, you can use a function like this to pad your string:
Public Function ConvertToBytes(p_sBits As String)
Dim iLength As Integer
Dim iBytes As Integer
iLength = Len(p_sBits)
If iLength Mod 8 > 0 Then
iBytes = Int(iLength / 8) + 1
Else
iBytes = Int(iLength / 8)
End If
ConvertToBytes = Right("00000000" & p_sBits, iBytes * 8)
End Function
Using SNMP version 3, I am creating a user.
Right now, I have it set up where I clone a user and that works just fine. However, I need to change the new user's authKey. How can I do this? I know the oid for authKeyChange, however, I don't know how to generate the new key. How do I generate that key? Can it be done using SNMPSharpNet?
If there is an easier way to do this while I'm creating the user, I can do that as well. ANY way to change the authKey (and privKey, but one step at a time) is much appreciated. I'm using VB.net if it means anything.
So I've figured out how to do this. It's a bit of a complex process. I followed this document, which is rfc2574. Do a ctrl+F for "keyChange ::=" and you'll find the paragraph walking you through the algorithm to generate the keyChange value. The following code has worked reliably to generate the keyChange value. All you have to do from this point is push the keyChange value to the usmAuthKeyChange OID. If you are changing the privacy password, you push the keyChange value to the usmPrivKeyChange OID. I'm ashamed to say that due to the time crunch, I did not have time to make this work completely, so when using SHA, I had to code an entirely new method that did almost the exact same thing. Again, I'm ashamed to post it, but I know how much I was banging my head against a wall, and if someone comes here later and sees this, I would like them to know what to do without going through the struggle.
Here is all of the code you need using VB.Net and the SNMPSharpNet library:
Private Function GenerateKeyChange(ByVal newPass As String, ByVal oldPass As String, ByRef target As UdpTarget, ByRef param As SecureAgentParameters) As Byte()
Dim authProto As AuthenticationDigests = param.Authentication
Dim hash As IAuthenticationDigest = Authentication.GetInstance(authProto)
Dim L As Integer = hash.DigestLength
Dim oldKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(oldPass), param.EngineId)
Dim newKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(newPass), param.EngineId)
Dim random() As Byte = Encoding.UTF8.GetBytes(GenerateRandomString(L))
Dim temp() As Byte = oldKey
Dim delta(L - 1) As Byte
Dim iterations As Integer = ((newKey.Length - 1) / L) - 1
Dim k As Integer = 0
If newKey.Length > L Then
For k = 0 To iterations
'Append random to temp
Dim merged1(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged1, 0)
random.CopyTo(merged1, random.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged1, 0, merged1.Length)
'Generate the first 16 values of delta
For i = 0 To L - 1
delta(k * L + i) = temp(i) Xor newKey(k * L + i)
Next
Next
End If
'Append random to temp
Dim merged(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged, 0)
random.CopyTo(merged, temp.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged, 0, merged.Length)
'Generate the first 16 values of delta
For i = 0 To (newKey.Length - iterations * L) - 1
delta(iterations * L + i) = temp(i) Xor newKey(iterations * L + i)
Next
Dim keyChange(delta.Length + random.Length - 1) As Byte
random.CopyTo(keyChange, 0)
delta.CopyTo(keyChange, random.Length)
Return keyChange
End Function
Private Function GenerateKeyChangeShaSpecial(ByVal newPass As String, ByVal oldPass As String, ByRef target As UdpTarget, ByRef param As SecureAgentParameters) As Byte()
Dim authProto As AuthenticationDigests = param.Authentication
Dim hash As IAuthenticationDigest = Authentication.GetInstance(authProto)
Dim L As Integer = 16
Dim oldKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(oldPass), param.EngineId)
Dim newKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(newPass), param.EngineId)
Array.Resize(oldKey, L)
Array.Resize(newKey, L)
Dim random() As Byte = Encoding.UTF8.GetBytes(GenerateRandomString(L))
Dim temp() As Byte = oldKey
Dim delta(L - 1) As Byte
Dim iterations As Integer = ((newKey.Length - 1) / L) - 1
Dim k As Integer = 0
If newKey.Length > L Then
For k = 0 To iterations
'Append random to temp
Dim merged1(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged1, 0)
random.CopyTo(merged1, random.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged1, 0, merged1.Length)
Array.Resize(temp, L)
'Generate the first 16 values of delta
For i = 0 To L - 1
delta(k * L + i) = temp(i) Xor newKey(k * L + i)
Next
Next
End If
'Append random to temp
Dim merged(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged, 0)
random.CopyTo(merged, temp.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged, 0, merged.Length)
Array.Resize(temp, L)
'Generate the first 16 values of delta
For i = 0 To (newKey.Length - iterations * L) - 1
delta(iterations * L + i) = temp(i) Xor newKey(iterations * L + i)
Next
Dim keyChange(delta.Length + random.Length - 1) As Byte
random.CopyTo(keyChange, 0)
delta.CopyTo(keyChange, random.Length)
Return keyChange
End Function
Private Function GenerateRandomString(ByVal length As Integer) As String
Dim s As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Dim r As New Random
Dim sb As New StringBuilder
For i As Integer = 1 To length
Dim idx As Integer = r.Next(0, 51)
sb.Append(s.Substring(idx, 1))
Next
Return sb.ToString()
End Function
Again, I am oh so well aware this code is hideous, but it works, and that is all I needed in the meantime. I understand this is technical debt and not the way I should code, but it's here and I hope you can get some use out of it.
If this doesn't work, don't forget to go to frc2574 and look at the algorithm.
Software: MS Visual Studio Shell 2013
I am currently working on a matrix heat map for an SSRS Report that I am trying to publish.
The textbox I am trying to apply the background to is grouped in by a row and column. It has a count function to determine the value of that cell.
Report Code I am using is:
public const ColorScaleRed = "#FF0000"
public const ColorScalePink= "#ff6666"
public function ColorScaleWPR(value, minValue, maxValue) as string
ColorScaleWPR = ColorScale3(value, _
minValue, "White", _
ColorScalePink, _
maxValue, ColorScaleRed)
end function
public function ColorScale3(value as object, minValue as object, minColor as string, midColor as string, maxValue as object, maxColor as string) as string
' Use average of minValue and maxValue as midValue
dim midValue as object
if IsNumeric(minValue) and IsNumeric(maxValue) then
midValue = (CDbl(minValue) + CDbl(maxValue)) / 2
end if
ColorScale3 = ColorScale3(value, _
minValue, minColor, _
midValue, midColor, _
maxValue, maxColor)
end function
public function ColorScale3(value as object, minValue as object, minColor as string, midValue as object, midColor as string, maxValue as object, maxColor as string) as string
if IsNumeric(value) and IsNumeric(midValue) and CDbl(value) < CDbl(midValue) then
ColorScale3 = ColorScale(value, minValue, minColor, midValue, midColor)
else
ColorScale3 = ColorScale(value, midValue, midColor, maxValue, maxColor)
end if
end function
public function ColorScale(value as object, minValue as object, minColor as string, maxValue as object, maxColor as string, optional errorColor as string = "Transparent") as string
ColorScale = errorColor
if not IsNumeric(value) or not IsNumeric(minValue) or not IsNumeric(maxValue) then
exit function
end if
' Do all calculations using doubles (can't mix doubles and decimals)
value = CDbl(value)
minValue = CDbl(minValue)
maxValue = CDbl(maxValue)
if minValue >= maxValue then
exit function
end if
if value <= minValue then
ColorScale = minColor
exit function
end if
if value >= maxValue then
ColorScale = maxColor
exit function
end if
dim scaleValue, r, g, b as double
dim minRGB, minR, minG, minB as integer
dim maxRGB, maxR, maxG, maxB as integer
scaleValue = (value - minValue) / (maxValue - minValue)
minRGB = GetRGB(minColor)
minR = minRGB / 2^16
minG = (minRGB mod 2^16) / 2^8
minB = minRGB mod 2^8
maxRGB = GetRGB(maxColor)
maxR = maxRGB / 2^16
maxG = (maxRGB mod 2^16) / 2^8
maxB = maxRGB mod 2^8
r = minR + ((maxR - minR) * scaleValue)
g = minG + ((maxG - minG) * scaleValue)
b = minB + ((maxB - minB) * scaleValue)
ColorScale = string.Format("#{0:X2}{1:X2}{2:X2}", _
CInt(Math.Floor(r)), _
CInt(Math.Floor(g)), _
CInt(Math.Floor(b)))
end function
private function GetRGB(colorStr as string) as integer
GetRGB = 0
if colorStr.StartsWith("#") then
GetRGB = Int32.Parse(colorStr.Substring(1), System.Globalization.NumberStyles.AllowHexSpecifier)
exit function
end if
dim c as System.Drawing.Color
c = System.Drawing.Color.FromName(colorStr)
GetRGB = (c.R * 2^16) + (c.G * 2^8) + c.B
end function
My problem is when i set the background expression.
I am able to get the heat map to properly render using the following expression:
=Code.ColorScaleWPR(Count(Fields!Candidate_ID.Value),0,10)
However, I don't want to use static values for the min and max values. I want them to be dynamic because depending on the parameters chosen those min and max values could vary widely.
So I used the following code
=Code.ColorScaleWPR(Count(Fields!Candidate_ID.Value), Min(Fields!Candidate_ID.Value,"DataSet1"), Max(Fields!Candidate_ID.Value,"DataSet1"))
When I run the report it renders completely white and none of the conditioning is applied to the cells.
Any suggestions to make it dynamic would be awesome.
Thanks!
I do not think that RS is able to calculate all groupings upfront then find min/max from them to apply color scale.
The best approach to try, is to calculate min and max values for every group into separate Dataset from the original Dataset query. Then pull needed values based on matching group criteria using expression. I would go that direction...
PS. I did not have enough time to make that beast alive for my case when I am using color scale on pivoted matrix groupings:)
What's the best way to test two Singles for equality in VB6?
I want to test two Single values for equality to 7 significant figures.
This MSDN article recommends using something like
If Abs(a - b) <= Abs(a / 10 ^ 7) Then
valuesEqual = True
End If
However, that can fail for certain values, e.g.
Public Sub Main()
Dim a As Single
Dim b As Single
a = 0.50000005
b = 0.50000014
Debug.Print "a = " & a
Debug.Print "b = " & b
Debug.Print "a = b: " & (a = b)
Debug.Print "SinglesAreEqual(a, b): " & SinglesAreEqual(a, b)
// Output:
// a = 0.5000001
// b = 0.5000001
// b = b: False
// SinglesAreEqual(a, b): False
End Sub
Private Function SinglesAreEqual(a As Single, b As Single) As Boolean
If Abs(a - b) <= Abs(a / 10 ^ 7) Then
SinglesAreEqual = True
Else
SinglesAreEqual = False
End If
End Function
The simplest way I've found of getting the result I need is to convert the values to strings, but seems horribly ugly:
Private Function SinglesAreEqual(a As Single, b As Single) As Boolean
SinglesAreEqual = (Str$(a) = Str$(b))
End Function
Are there any better ways?
I maintain a CAD/CAM application and I have to deal with floating point numbers all the time. I have a function that I call fComp that I pass a floating point value when I need to test for equality. fComp call a rounding function set to a certain level of precision. For our system I round to 6 decimal places. Yours may need higher or get away with lower it depends on the application.
The fComp Function exists so I have one spot to change the rounding factor used in these calculations. This proved handy a couple of years back when we started manufacturing higher precision machines.
Public Function pRound(ByVal Value As Double, ByVal Power As Double) As Double
Dim TempValue As Double
Dim tSign As Double
TempValue = Value
tSign = TempValue
TempValue = Abs(TempValue)
TempValue = TempValue * 10 ^ (Power * -1)
TempValue = Fix(TempValue + 0.5)
TempValue = TempValue / 10 ^ (Power * -1)
pRound = TempValue * Sign(tSign)
End Function
To round to the 6th decimal place you go
RoundedNumber = pRound(MyValue, -6)
Negative is to the right of the decimal place positive to the left.
Instead if rounding and testing for equality, you can take the difference of two numbers and compare that with a factor
If Abs(a - b) < 0.000001 Then
You can adjust the 0.000001 to whatever resolution you need
I don't believe you can use the single data type to that many significant figures. You would need to use double instead:
Dim a As Single
Dim s As String
s = "0.50000005"
a = 0.50000005
Debug.Print s & " " & a
The above outputs:
0.50000005
0.5000001