I can find plenty of tutorials on how to use conditional formatting of tablix fields in Report Builder 3.0. However I would like a function that creates a gradient color, from black to red, which colors the text more and more red, the closer it comes to a certain number.
For example I got a column with the age of a product component in days. I want the text to be black (#000000), when the component is 0 days old. And then gradually turn into red, hitting a pure red (#FF0000) on the day it expires (could be day 30).
Can anyone provide me any information, regarding how to do that?
I ended up modifying the function from the solution linked by Alejandro.
Public Shared Function ColorDWB(ByVal Value As Decimal, ByVal MaxPositive As Decimal, ByVal Neutral As Decimal, ByVal ColStr As String) As String
'Initiate variables for Red, Green and Blue (RGB)
Dim ColVar1 As Integer
Dim ColVar2 As Integer
Dim ColVar3 As Integer
'Split the #RGB color to R, G, and B components
ColVar1=Convert.ToInt32(left(right(ColStr, 6),2),16)
ColVar2=Convert.ToInt32(left(right(ColStr, 4),2),16)
ColVar3=Convert.ToInt32(right(ColStr, 2),16)
'Find Largest Range
Dim decPosRange As Decimal = Math.Abs(MaxPositive - Neutral)
Dim iColor1 As Integer
Dim iColor2 As Integer
Dim iColor3 As Integer
Dim strColor As String
'Reduce a shade for each of the R,G,B components
iColor1 = Math.Max(0, Math.Min(ColVar1, ColVar1*(Value-Neutral)/(MaxPositive-Neutral)))
iColor2 = Math.Max(0, Math.Min(ColVar2, ColVar2*(Value-Neutral)/(MaxPositive-Neutral)))
iColor3 = Math.Max(0, Math.Min(ColVar3, ColVar3*(Value-Neutral)/(MaxPositive-Neutral)))
'Return the new color
strColor = "#" & iColor1.ToString("X2") & iColor2.ToString("X2") & iColor3.ToString("X2")
Return strColor
End Function
Like the answer before me, that article got me started but I modified to make it work better for my purposes.
Public Function HeatMap(ByVal Value As Double _
, ByVal MinVal As Double _
, ByVal MaxVal As Double _
, ByVal RValLo As Double _
, ByVal GValLo As Double _
, ByVal BValLo As Double _
, ByVal RValHi As Double _
, ByVal GValHi As Double _
, ByVal BValHi As Double _
) As String
Dim DiffPercent As Double
Dim RNew As Integer
Dim GNew As Integer
Dim BNew As Integer
Dim HeatMapColor As String
If Value = Nothing Then
RNew = 255
GNew = 255
BNew = 255
ElseIf Value <= MinVal Then
RNew = RValLo
GNew = GValLo
BNew = BValLo
ElseIf Value >= MaxVal Then
RNew = RValHi
GNew = GValHi
BNew = BValHi
Else
DiffPercent = (Value - MinVal) / (MaxVal - MinVal)
RNew = RValLo - Round((RValLo - RValHi) * DiffPercent, 0)
GNew = GValLo - Round((GValLo - GValHi) * DiffPercent, 0)
BNew = BValLo - Round((BValLo - BValHi) * DiffPercent, 0)
End If
HeatMapColor = "#" & Hex(RNew) & Hex(GNew) & Hex(BNew)
HeatMap = HeatMapColor
End Function
More info on my approach here: How to create heat map on a table in SSRS?
Related
I'm attempting to write a program that involves finding strings with numerical values that are +1 and -1 from the numerical value located within another string. (The rest of the program is fine, it's just this section that I'm having a difficult time with).
For example:
If I have the parent string: name[CE18.2]-abritraryinfo
I need to find a way to isolate that 18.2 so that I can add 1 to it and subtract 1 from it to create two new numerical values of 19.2 and 17.2
I need to be able to do this in such a way that I can find this number in strings whose 'name' section and whose number after CE vary according to the different parent strings.
What I've tried already is this:
'''
Result = Empty 'Resets the value of the result after it changes to the next name
f = InStr(c, "CE") 'Finds at which position in the string CE is located. The position is the C of CE
z = Mid(c, f, 8) 'Pulls 8 units from the string starting at the position dictated by f
stringLength = Len(z) 'Gives the Length of the section pulled by Z
For i = 1 To stringLength 'From the first position to the final position
If IsNumeric(Mid(z, i, 1)) Then
Result = Result & Mid(z, i, 1) 'Gives the numbers in the string section pulled by Z
End If
Next i
'''
but it doesn't work as it ignores the decimal point.
Any advice would be incredibly helpful! Thanks in advance!
One of the simple solution is:
Sub test1()
inputS = "name[CE18.2]-abritraryinfo"
pos = InStr(inputS, "[CE")
If pos > 0 Then
x = Val(Mid(inputS, pos + 3))
Debug.Print x, x - 1, x + 1
End If
End Sub
Output:
18,2 17,2 19,2
String Between Two Strings
Option Explicit
Sub gsbtsTEST()
Const lStr As String = "CE"
Const rStr As String = "]"
Const sString As String = "name[CE18.2]-abritraryinfo"
Dim ResString As String
ResString = GetStringBetweenTwoStrings(sString, lStr, rStr)
Dim ResValue As Double
If IsNumeric(ResString) Then
ResValue = Val(ResString)
End If
Debug.Print ResString, ResValue - 1, ResValue, ResValue + 1
End Sub
Function GetStringBetweenTwoStrings( _
ByVal sString As String, _
ByVal lStr As String, _
ByVal rStr As String, _
Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As String
Dim lPos As Long: lPos = InStr(1, sString, lStr, CompareMethod)
If lPos = 0 Then Exit Function
Dim rPos As Long: rPos = InStr(1, sString, rStr, CompareMethod)
If rPos = 0 Then Exit Function
lPos = lPos + Len(lStr)
If lPos < rPos Then
GetStringBetweenTwoStrings = Mid(sString, lPos, rPos - lPos)
End If
End Function
I have a function which returns average RGB value of a region drawn on a picturebox in VB.net.
The code is as below:
Function GetAvgRGB(ByVal CrdY As Integer, ByVal CrdX As Integer, ByVal Region As System.Drawing.Rectangle) As Tuple(Of Integer, Integer, Integer)
Dim totalR As UInteger
Dim totalG As UInteger
Dim totalB As UInteger
For y As Integer = CrdY - (Region.Height / 2) To CrdY + ((Region.Height / 2) - 1)
For x As Integer = CrdX - (Region.Width / 2) To CrdX + ((Region.Width / 2) - 1)
totalR += myBitmap.GetPixel(x, y).R
totalG += myBitmap.GetPixel(x, y).G
totalB += myBitmap.GetPixel(x, y).B
Next
Next
Dim pixelCount As Integer = Region.Width * Region.Height
Dim averageR As Integer = CType(totalR \ pixelCount, Integer)
Dim averageG As Integer = CType(totalG \ pixelCount, Integer)
Dim averageB As Integer = CType(totalB \ pixelCount, Integer)
Return Tuple.Create(averageR, averageG, averageB)
End Function
My query is how do I separate the values of R, G & B returned by this function..
Use the Item property.
Dim myTuple = GetAvgRGB(?,?,?)
Dim r = myTuple.Item1 ' g = .Item2, b = .Item3
After I inserted custom code in my SSRS report I got this error:
An error occurred during local report processing. The definition of the report ...in invalid. An unexpected error occured while compiling expressions. Native compiler return valid '[BC42105]' Function 'ColorDWB' doesn't return a value on all code paths. A null reference exception could occur at a run time when the result is used.
All I am trying to do is create a Excel like heat map based on shades of colors.
My custom code:
Public Shared Function ColorDWB(ByVal Value As Decimal, ByVal MaxPositive As Decimal,
ByVal Neutral As Decimal, ByVal ColStr As String) As String
Dim ColVar1 As Integer Dim ColVar2
As Integer Dim ColVar3 As Integer ‘Split the #RGB color to R, G, and B components
ColVar1=Convert.ToInt32(left(right(ColStr, 6),2),16)
ColVar2=Convert.ToInt32(left(right(ColStr, 4),2),16)
ColVar3=Convert.ToInt32(right(ColStr, 2),16) ‘Find Largest Range Dim decPosRange
As Decimal = Math.Abs(MaxPositive – Neutral) ‘Find appropriate color shade
Dim Shd As Decimal = 255
Dim iColor1 As Integer
Dim iColor2 As Integer
Dim iColor3 As Integer
Dim strColor As String ‘Reduce a shade for each of the R,G,B components
iColor1 = ColVar1 + CInt(Math.Round((MaxPositive-Value) * ((Shd – ColVar1) / decPosRange)))
iColor2 = ColVar2 + CInt(Math.Round((MaxPositive-Value) * ((Shd – ColVar2) / decPosRange)))
iColor3 = ColVar3 + CInt(Math.Round((MaxPositive-Value) * ((Shd – ColVar3) / decPosRange)))
strColor = “#” & iColor1.ToString(“X2”) & iColor2.ToString(“X2”) & iColor3.ToString(“X2”)
Return strColor
End Function
And its not a first code that gives me the same error. I dont know much about VB. What am I missing here?
I've corrected and tested your function:
Public Shared Function ColorDWB(ByVal Value As Decimal, ByVal MaxPositive As Decimal, ByVal Neutral As Decimal, ByVal ColStr As String) As String
Dim ColVar1 As Integer
Dim ColVar2 As Integer
Dim ColVar3 As Integer
'Split the #RGB color to R, G, and B components
ColVar1 = Convert.ToInt32(left(right(ColStr, 6), 2), 16)
ColVar2 = Convert.ToInt32(left(right(ColStr, 4), 2), 16)
ColVar3 = Convert.ToInt32(right(ColStr, 2), 16)
'Find Largest Range
Dim decPosRange As Decimal = Math.Abs(MaxPositive - Neutral)
'Find appropriate color shade
Dim Shd As Decimal = 255
Dim iColor1 As Integer
Dim iColor2 As Integer
Dim iColor3 As Integer
Dim strColor As String
'Reduce a shade for each of the R,G,B components
iColor1 = ColVar1 + CInt(Math.Round((MaxPositive - Value) * ((Shd - ColVar1) / decPosRange)))
iColor2 = ColVar2 + CInt(Math.Round((MaxPositive - Value) * ((Shd - ColVar2) / decPosRange)))
iColor3 = ColVar3 + CInt(Math.Round((MaxPositive - Value) * ((Shd - ColVar3) / decPosRange)))
'Return the new color
strColor = "#" & iColor1.ToString("X2") & iColor2.ToString("X2") & iColor3.ToString("X2")
Return strColor
End Function
Maybe you need to do some fixes, but it works.
Here is a fiddle: https://dotnetfiddle.net/g3nR0O
How can I create like this in SSRS? The color will change from red to green based on a value in a row (Underwriter). And all that in a group:
You can do this by right clicking on the individual cells and setting the fill colour based on an expression:
In the Image below I've mistakingly put "==" where it should be "="
To give you an example the following:
was created using the following expressions for the ID30, ID60 and ID90 fields respectively:
ID30:
=IIF(Fields!ID30.Value>="0" And Fields!ID30.Value<="100" ,"#c6c626",IIF(Fields!ID30.Value>="100" And Fields!ID30.Value<="200" ,"#c6c627",IIF(Fields!ID30.Value>="200","#9e2424","red")))
ID60:
=IIF(Fields!ID60.Value>="0" And Fields!ID60.Value<="100" ,"#c6c626",IIF(Fields!ID60.Value>="100" And Fields!ID60.Value<="200" ,"#c6c627",IIF(Fields!ID60.Value>="200","#9e2424","red")))
ID90:
=IIF(Fields!ID90.Value>="0" And Fields!ID90.Value<="100" ,"#c6c626",IIF(Fields!ID90.Value>="100" And Fields!ID90.Value<="200" ,"#c6c627",IIF(Fields!ID90.Value>="200","#9e2424","red")))
I came up with a way to get the color to actually be gradient, rather then based on nested IF statements. This method uses theoretical min and max values (you could set actual min and max values as variables if it is important that these are precise) and rgb integer values and results in a color hex code for SSRS.
Go to Report Properties>Code and paste in this function:
Public Function HeatMap(ByVal Value As Double _
, ByVal MinVal As Double _
, ByVal MaxVal As Double _
, ByVal RValLo As Double _
, ByVal GValLo As Double _
, ByVal BValLo As Double _
, ByVal RValHi As Double _
, ByVal GValHi As Double _
, ByVal BValHi As Double _
) As String
Dim DiffPercent As Double
Dim RNew As Integer
Dim GNew As Integer
Dim BNew As Integer
Dim HeatMapColor As String
If Value = Nothing Then
RNew = 255
GNew = 255
BNew = 255
ElseIf Value <= MinVal Then
RNew = RValLo
GNew = GValLo
BNew = BValLo
ElseIf Value >= MaxVal Then
RNew = RValHi
GNew = GValHi
BNew = BValHi
Else
DiffPercent = (Value - MinVal) / (MaxVal - MinVal)
RNew = RValLo - Round((RValLo - RValHi) * DiffPercent, 0)
GNew = GValLo - Round((GValLo - GValHi) * DiffPercent, 0)
BNew = BValLo - Round((BValLo - BValHi) * DiffPercent, 0)
End If
HeatMapColor = "#" & Hex(RNew) & Hex(GNew) & Hex(BNew)
HeatMap = HeatMapColor
End Function
Then in the cell where the heat map values are calculated, use the function in the background format expression, for example:
=Code.HeatMap(Sum(Fields!Orders.Value) / Sum(Fields!Orders.Value, "Tablix1"), 0, .2, 255, 255, 255, 99, 190, 123)
In this example, there are theoretical low and high values of 0 and .2 (0% and 20%) and the color will go between white on the low side and a green shade on the high side. Anything less than the min gets the min color and anything greater than the max gets the max color. This would also work if you want to go between two colors on the color wheel and if you wanted to go with something like red for negative values, white for zero, and green for positive values, you just use an IF statement and use the function twice, once for negative values and once for >= 0. Just substitute rgb values as necessary.
What is best way to force fit the columns of msflexgrid in vb6?
so, that all columns are visible and they occupies maximum width of grid!
I've tried this code but it does not properly fit last column inside the grid, can anyone suggest what could be problem?
Public Sub **FlexGrid_AutoSizeColumns (** ByRef pGrid As MSHFlexGrid, _
ByRef pForm As Form, _
Optional ByVal pIncludeHeaderRows As Boolean = True, _
Optional ByVal pAllowShrink As Boolean = True, _
Optional ByVal pMinCol As Long = 0, _
Optional ByVal pMaxCol As Long = -1, _
Optional ByVal pBorderSize As Long = 8, _
Optional fitToScreen As Boolean = False **)**
Dim lngMinCol As Long, lngMaxCol As Long, lngCurrRow As Long
Dim lngMinRow As Long, lngMaxRow As Long, lngCurrCol As Long
Dim lngMaxWidth As Long, lngCurrWidth As Long
Dim fntFormFont As StdFont
Dim totalWidth As Integer
totalWidth = 0
Set fntFormFont = New StdFont
Call CopyFont(pForm.Font, fntFormFont)
Call CopyFont(pGrid.Font, pForm.Font)
With pGrid
lngMinCol = pMinCol
lngMaxCol = IIf(pMaxCol = -1, .Cols - 1, pMaxCol)
lngMinRow = IIf(pIncludeHeaderRows, 0, .FixedRows)
lngMaxRow = .Rows - 1
For lngCurrCol = lngMinCol To lngMaxCol
lngMaxWidth = IIf(pAllowShrink, 0, pForm.ScaleX(.ColWidth(lngCurrCol), vbTwips, pForm.ScaleMode))
For lngCurrRow = lngMinRow To lngMaxRow '..find widest text (in scalemode of the form)
lngCurrWidth = pForm.TextWidth(Trim(.TextMatrix(lngCurrRow, lngCurrCol)))
If lngMaxWidth < lngCurrWidth Then lngMaxWidth = lngCurrWidth
Next lngCurrRow
lngMaxWidth = pForm.ScaleX(lngMaxWidth, pForm.ScaleMode, vbTwips)
.ColWidth(lngCurrCol) = lngMaxWidth + (pBorderSize * Screen.TwipsPerPixelX)
totalWidth = .ColWidth(lngCurrCol) + totalWidth
Next lngCurrCol
End With
Call CopyFont(fntFormFont, pForm.Font)
If fitToScreen = True Then
Dim i As Integer
Dim gridWidth As Long
gridWidth = pGrid.Width
For i = 0 To pGrid.Cols - 1
pGrid.ColWidth(i) = Int(gridWidth * pGrid.ColWidth(i) / totalWidth)
Next
End If
End Sub
One way I could think is to resize your columns (with visibility) to fit into the max width found in a column (text). The function returns either 0 or a double value. As long as the returned max column width is not zero, we may adjust the current grid column width accordingly. If zero then it remains the same.
Dim i, j, as Integer
Dim maxWidth as Double
For i = 0 to MsFlexGrid1.Rows - 1
For j = 0 to MsFlexGrid1.Cols - 1
maxWidth = maxColWidth(j)
If maxWidth > 0 then
MsFlexGrid.ColWidth(j) = maxWidth
End If
Next j
Next i
Private Function maxColWidth(coNum as Integer) as Double
Dim i, Max as Integer
Max = 0
With MsFlexGrid1
For i = .FixedRows to .Rows-1
If TextWidth(.TextMatrix(i, colNum)) > Max Then
Max = TextWidth(.TextMatrix(i, colNum))
End If
Next i
maxColWidth = Max
End With
End Function
to distribute the remaining space over the columns, divide it by the number of columns and add it to each column
'1 form with :
' 1 msflexgrid : name=MSFlexGrid1
Option Explicit
Private Sub Form_Load()
Dim intCol As Integer
'example form and grid configuration
Move 0, 0, 10000, 5000
With MSFlexGrid1
.FixedRows = 0
.FixedCols = 0
.Rows = 10
.Cols = 10
For intCol = 0 To .Cols - 1
.ColWidth(intCol) = (intCol + 1) * 107
Next intCol
End With 'MSFlexGrid1
End Sub
Private Sub Form_Resize()
MSFlexGrid1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub MSFlexGrid1_Click()
DistributeWidth
End Sub
Private Sub DistributeWidth()
Dim intCol As Integer, intColSel As Integer
Dim lngWidth As Long
Dim lngRemaining As Long
Dim lngExpand As Long
With MSFlexGrid1
intColSel = .Col 'remember selected column
.Col = 0 'select first column to ...
lngWidth = .Width - .CellLeft * 2 '... take flexgrid-borders into account
.Col = intColSel 'select column again
lngRemaining = lngWidth - InUse 'calculate the remaining space
If lngRemaining > 0 Then
lngExpand = lngRemaining \ .Cols 'distribute the remaining space over the columns
For intCol = 0 To .Cols - 1
.ColWidth(intCol) = .ColWidth(intCol) + lngExpand
Next intCol
lngExpand = lngRemaining Mod .Cols
.ColWidth(.Cols - 1) = .ColWidth(.Cols - 1) + lngExpand 'since we are working with longs, apply the remaining fraction to the last column
Else
'what to do with lack of space? Shrink columns or expand grid or nothing?
End If
End With 'MSFlexGrid1
End Sub
Private Function InUse() As Long
'calculate how much of the gridwidth is already in use by the columns
Dim intCol As Integer
Dim lngInUse As Long
With MSFlexGrid1
lngInUse = 0
For intCol = 0 To .Cols - 1
lngInUse = lngInUse + .ColWidth(intCol)
Next intCol
End With 'MSFlexGrid1
InUse = lngInUse
End Function
The above example somehow does not always fill the area completely, although i think the logic is correct and i can't see anything missing ...
i guess this gives a similar result to what you have? or is it slightly better?