SSRS 2013 Heat Map - visual-studio

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:)

Related

Change authKey of a user

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.

Can anyone improve on the below Fuzzyfind function for VBA?

This function lets you find similar strings from a range without having to do an exact search.
The formula looks like this: =FuzzyFind(A1,B$1:B$20)
assuming the string you are performing a search for is in A1
and your reference or options table is B1:B20
The code is here:
Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
str = cell
For i = 1 To Len(lookup_value)
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
a = a + 1
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
Next i
a = a - Len(cell)
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind = Value
End Function
The results from this function are hit and miss. Can anyone improve the intelligence of this algorithm?
Thank you :)
I'm not sure exactly what "FuzzyFind" entails, but this is a VLOOKUP that uses the Levenshtein distance to find similar data.
The Levenshtein distance lets you select a "percentage match" that you can specify instead of the typical TRUE or FALSE from a normal VLOOKUP:
Usage is: DTVLookup(A1,$C$1:$C$100,1,90) where 90 is the Levenshtein Distance.
DTVLookup(Value To Find, Range to Search, Column to Return, [Percentage Match])
I typically use this when comparing names that come from different databases like:
Correct Name Example Lookup Percentage Match Other Report
John S Smith John Smith 83 John Smith
Barb Jones Barbara Jones 77 Barbara Jones
Jeffrey Bridge Jeff Bridge 79 Jeff Bridge
Joseph Park Joseph P. Park 79 Joseph P. Park
Jefrey Jones jefre jon 75 jefre jon
Peter Bridge peter f. bridge 80 peter f. bridge
Here's the code:
Function DTVLookup(TheValue As Variant, TheRange As Range, TheColumn As Long, Optional PercentageMatch As Double = 100) As Variant
If TheColumn < 1 Then
DTVLookup = CVErr(xlErrValue)
Exit Function
End If
If TheColumn > TheRange.Columns.Count Then
DTVLookup = CVErr(xlErrRef)
Exit Function
End If
Dim c As Range
For Each c In TheRange.Columns(1).Cells
If UCase(TheValue) = UCase(c) Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
ElseIf PercentageMatch <> 100 Then
If Levenshtein3(UCase(TheValue), UCase(c)) >= PercentageMatch Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
End If
End If
Next c
DTVLookup = CVErr(xlErrNA)
End Function
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long
Dim i As Long, j As Long, string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long
string1_length = Len(string1): string2_length = Len(string2)
distance(0, 0) = 0
For i = 1 To string1_length: distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next
For j = 1 To string2_length: distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next
For i = 1 To string1_length
For j = 1 To string2_length
If smStr1(i) = smStr2(j) Then
distance(i, j) = distance(i - 1, j - 1)
Else
min1 = distance(i - 1, j) + 1
min2 = distance(i, j - 1) + 1
min3 = distance(i - 1, j - 1) + 1
If min2 < min1 Then
If min2 < min3 Then minmin = min2 Else minmin = min3
Else
If min1 < min3 Then minmin = min1 Else minmin = min3
End If
distance(i, j) = minmin
End If
Next
Next
' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and Lengths etc...
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100) / MaxL)
End Function
Try this out, I think it will find the best match
Function FuzzyFind2(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = cell
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, lookup_value) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, lookup_value) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind2 = Value
End Function
I've been looking for this theme a lot and definitely Holmes IV answer is the best. I would just add a small update to compare always in uppercase. For my problems it recommended me more accurate options.
Function FuzzyFind3(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = UCase(cell)
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, UCase(lookup_value)) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, UCase(lookup_value)) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind3 = Value

AsymUp function (Rounding) not producing desired results - VB6

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.

Classic ASP Random Letter

I would like to know if there is a way to get a random letter (from A-Z)
Thanks for any help.
I think this is what you're looking for. Generate a Random Letter in ASP:
Function RandomNumber(LowNumber, HighNumber)
RANDOMIZE
RandomNumber = Round((HighNumber - LowNumber + 1) * Rnd + LowNumber)
End Function
Assign the function to a variable and pass in the LowNumber (26) and
the HighNumber (97) and convert the value returned to the character it
represents:
RandomLetter = CHR(RandomNumber(97,122))
You'll want your range to be between 65 and 90 (A and Z) for capital letters.
Roger Baretto's answer fixed with Cem's hint ))
Function RandomString(iSize)
Const VALID_TEXT = "abcdefghijklmnopqrstuvwxyz1234567890"
Dim Length, sNewSearchTag, I
Length = Len(VALID_TEXT)
Randomize()
For I = 1 To iSize
sNewSearchTag = sNewSearchTag & Mid(VALID_TEXT, Int(Rnd()*Length + 1), 1)
Next
RandomString = sNewSearchTag
End Function
Here is another way to look at it without using an if/switch.
String alphabet = "abcdefghijklmnopqrstuvwxyz";
Random rand = new Random();
char randomCharacter = alphabet[rand.Next(0, 25)];
I came to a solution that you can have easy control of what are the valid values for your generator.
Function CreateRandomString(iSize)
Const VALID_TEXT = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
Dim sNewSearchTag
Dim I
For I = 0 To iSize
Randomize
sNewSearchTag = sNewSearchTag & Mid(VALID_TEXT,Round(Rnd * Len(VALID_TEXT)),1)
Next
CreateRandomString = sNewSearchTag
End Function
use a random number... like this:
Function RandomNumber(LowNumber, HighNumber)
RANDOMIZE
RandomNumber = Round((HighNumber - LowNumber + 1) * Rnd + LowNumber)
End Function
and then use it from 1-26, use "if" or switch, to get the letter.
Rogerio's answer is fine but Round(Rnd * Len(VALID_TEXT)) can be 0 and Mid cannot start from 0. Fix it if you want to use this function.

Floating point comparison in VB6

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

Resources