SSRS gradient color heatmap. Change from "blue to red" to "green to red" - reporting-services

I am building a SSRS report and using a gradient color heatmap using a snippet that I found on another site. It works well, but produces a "blue to red" color scale. I am not pro enough to change this code to do a "green to red" color scale. Any advice would be super helpful.
Thanks!
Public Function ColorRYG(ByVal Value As Decimal, ByVal MaxPositive As Decimal, ByVal MaxNegative As Decimal, ByVal Neutral As Decimal) As String
'Example: =code.ColorBack(expression, Max(expression), Min(expression), 0)
'=code.colorback( Fields!Sales.Value,max( Fields!Sales.Value),min( Fields!Sales.Value),0)
'Find Largest Range
Dim decRange As Decimal
Dim decPosRange As Decimal = Math.Abs(MaxPositive - Neutral)
Dim decNegRange As Decimal = Math.Abs(MaxNegative - Neutral)
decRange = IIf(decPosRange > decNegRange, decPosRange, decNegRange)
'Force color into Max-Min Range. Important if you want to Clip the color display to a subset of the data range. Value = Switch((Value > MaxPositive), MaxPositive, Value < MaxNegative, MaxNegative, True, Value) 'Find Delta required to change color by 1/255th of a shade
Dim decColorInc As Decimal = 255 / decRange
'Find appropriate color shade
Dim iColor As Integer = CInt(Math.Round((Value - Neutral) * decColorInc))
'Return Appropriate +ve or -ve color
Dim strColor As String
If iColor >= 0 Then
'Green
iColor = 255 - iColor 'Thus 0 = White & 255 = Green
strColor = "#" & Math.Abs(iColor).ToString("X2") & Math.Abs(iColor).ToString("X2") & "FF"
Else
'Red
iColor = iColor + 255 'NB iColour is -ve; -1 - -255
strColor = "#FF" & Math.Abs(iColor).ToString("X2") & Math.Abs(iColor).ToString("X2")
End If
Return strColor
end function
I tried changing some part of the code that I deemed responsible for the color coding but couldnt change it to green

I've got no way to test this at the moment but give this a try...
First, I've taken the "Green" section of code and broken down the part where strColor is set, so you can see how each part of the colour is made up. The color are being set in Hex notation so #FFFFFF is white #000000 is black, #FF0000 is solid red as each pair of characters represent the red, green and blue values between #00 and #FF (0 - 255)
So here's your existing code
strColor = "#" &
Math.Abs(iColor).ToString("X2") & ' red
Math.Abs(iColor).ToString("X2") & ' green
"FF" ' blue
I think a simple change like this might fix it (but not sure as I can't test)
strColor = "#" &
Math.Abs(iColor).ToString("X2") & ' red
"FF" & ' green
Math.Abs(iColor).ToString("X2") ' blue
Here we are maxing out the green value to FF (255) but making the red and blue value variable based on iColor. The is the opposite of what the original code did where blue was fixed as FF and green and red were variable.

Related

Excel Macro VBA Use HTML Tags Bold Italics Underline Strong in Cell

I have been looking to convert a string or cell such as:
[Cell B2 Example]
"This is a <b>test</b> cell <i>filled</i> with <strong>randomly placed html tags</strong>."
[Needed Output Example] "This is a test cell filled with randomly placed html tags."
I need to be able to process multiple types of tags (<b></b> , <i></i> , <u></u> , <strong></strong>) in the same cell or string.
So far, someone has helped me with getting this far:
Dim Tag, Tend, Pstart, Pend As String
'BOLD Text
Tag = "<b>" ' tag string: start
Tend = "</b>" ' tag string: end
Pstart = 0 ' vector index of Pos()
Pend = 1 ' vector index of Pos()
Dim Cv As String ' Cell value
Dim Cnt As Integer ' instances of bold expressions
Dim Pos() As Variant ' string positions: 0 = start, 1 = End
Dim f As Integer ' loop counter: Cnt
Cv = Range("B2").Value
Cnt = (Len(Cv) - Len(Replace(Cv, Tag, ""))) / 3
ReDim Pos(Cnt, Pend)
For f = 1 To Cnt
Pos(f, Pstart) = InStr(Cv, Tag)
Cv = Left(Cv, Pos(f, Pstart) - 1) & Mid(Cv, Pos(f, Pstart) + Len(Tag), Len(Cv))
Pos(f, Pend) = InStr(Cv, Tend) - 1
Cv = Left(Cv, Pos(f, Pend)) & Mid(Cv, Pos(f, Pend) + Len(Tend) + 1, Len(Cv))
Next f
With Range("B2")
.Font.Bold = False
.Value = Cv
For f = 1 To Cnt
.Characters(Pos(f, Pstart), Pos(f, Pend) - Pos(f, Pstart) + 1).Font.Bold = True
Next f
End With
The above successfully makes needed text bold AND removes the visual tags from the cell.
However, when trying to also incorporate italics, underline, and strong tags, it only does which ever come last. The rest get wiped out.
Is there a better way to do this?
Can multiple html tags be converted in excel strings or cells WITHOUT having to open other applications such as IE, etc?
Side note, as for the tags, it would be fine if they functioned the same as bold, if that makes it easier?
As soon as you assign the cell's .Value property, any per-character font formatting will be lost, so you can't do that as part of the formatting process.
Here's one way to do it - not bulletproof and will not account for (eg) nested sets of the same tag or invalid HTML...
Sub Tester()
Dim c As Range
Set c = ActiveSheet.Range("D5")
ActiveSheet.Range("D2").Copy c 'for testing:copy the input string
FormatTags c, "b", "bold"
FormatTags c, "i", "italic"
FormatTags c, "strong", "bold"
FormatTags c, "u", "underline"
End Sub
Sub FormatTags(c As Range, tag As String, prop As String)
Dim pOpen As Long, pClose As Long, numChars As Long
Dim sOpen, sClose
sOpen = "<" & tag & ">" 'the open tag
sClose = "</" & tag & ">" 'close tag
pOpen = InStr(c.Value, sOpen) 'have an open tag?
Do While pOpen > 0
pClose = InStr(pOpen + 1, c.Value, sClose) 'find next close tag
If pClose > 0 Then
c.Characters(pClose, Len(sClose)).Delete 'remove the close tag first
c.Characters(pOpen, Len(sOpen)).Delete 'remove the open tag
'set the named font property
numChars = pClose - (pOpen + Len(sOpen))
CallByName c.Characters(pOpen, numChars).Font, prop, VbLet, True
pOpen = InStr(c.Value, sOpen) 'find next, if any
Else
Exit Do 'no closing tag - all done
End If
Loop
End Sub
Edit - if you're interested in a more general-purpose approach which doesn't involve IE you can copy the HTML to the clipboard and paste it to a cell. That will give you the formatting you want.
Eg - using #GMCB's code from here: Injecting RTF code in the Clipboard to paste into MS Word as RTF text via a VBA macro
With ActiveSheet
myClipboard.SetClipboardText .Range("D5").value, "HTML Format"
.Paste Destination:=.Range("D5")
End With

Setting Access Colour Codes in VBA

I'm having trouble setting the back ground colour of a textbox in my Access database. I want to change the colour to red when certain conditions are met.
In design view I've set the textbox's back color property to red and it is shown as '#ED1C24'. When I view the form in Form view the control is correctly shown in the red colour I've chosen.
But when I put this value into my VBA code (Text1.Backcolor = "#ED1C24") I get a type mismatch error.
I've tried changing it to a Hex number (Text1.Backcolor = &HED1C24) but then the control turns blue.
Any help would be appreciated. Thanks.
I wrote a blog about this very problem a while ago which should answer your question.
http://www.jht.co.uk/access-colour-color-codes/
Here's the code:
Public Function HTMLColour(HTMLCode As String, Optional Red As Variant, _
Optional Green As Variant, Optional Blue As Variant) As Long
On Error GoTo HTMLColour_Error
'Converts an HTML colour code number to a long interger
'Also returns the constituent R,G & B components through supplied parameters
Dim intR As Integer, intG As Integer, intB As Integer
Dim strHTML As String
'Strip # prefix if supplied
If Len(HTMLCode) < 6 Then Exit Function
strHTML = Right(HTMLCode, 6)
'Extract R, G, B values
intR = CInt("&H" & Mid(strHTML, 1, 2))
intG = CInt("&H" & Mid(strHTML, 3, 2))
intB = CInt("&H" & Mid(strHTML, 5, 2))
'Return optional parameters
If Not IsMissing(Red) Then Red = intR
If Not IsMissing(Green) Then Green = intG
If Not IsMissing(Blue) Then Blue = intB
'Convert RGB to Long integer
HTMLColour = RGB(intR, intG, intB)
HTMLColour_Exit:
Exit Function
HTMLColour_Error:
MsgBox Err.Description, vbExclamation, "Function HTMLColour"
Resume HTMLColour_Exit
End Function
Hope this helps.
The color code format in VBA is RGB or Long, and not HEX
In your case the easiest way is to call a function that will convert from HEX to Long:
Public Function Color_Hex_To_Long(strColor As String) As Long
Dim iRed As Integer
Dim iGreen As Integer
Dim iBlue As Integer
strColor = Replace(strColor, "#", "")
strColor = Right("000000" & strColor, 6)
iBlue = Val("&H" & Mid(strColor, 1, 2))
iGreen = Val("&H" & Mid(strColor, 3, 2))
iRed = Val("&H" & Mid(strColor, 5, 2))
Color_Hex_To_Long = RGB(iRed, iGreen, iBlue)
End Function
Use it like this :
Text1.BackColor = Color_Hex_To_Long("#ED1C24")
Simply use OnCurrent properties to set your font properties or other properties.
Instead of entering the Hex color codes, easier to use MS Access proprietary codes that are entirely in numbers. Do the easy way. Cheers! Mikey
For MS_ACCESS 2016 the long value seems to be just the .backcolor value, converting the HEX using the functions above won't work.
I'd just create a text box and a label, colour the label as you wish in design view and set the textbox value to txtBlue = lblBlue.backcolour in VBA.
I'm not sure if this is the case in other versions of excel but it seems to be the case in Office 2016.

VBA To Change BackColor Of Rectangle - Access

So I'm trying to change the backcolor of a rectangle within Access. I know you can easily do this Box1.BackColor = RGB(0, 0, 0), however I want to enter a value into a textbox and then display that color value as soon as you update the textbox.
I thought the following would work, but it doesn't.
Textbox1 = 0, 0, 0
Dim P1 as String
P1 = "RGB(" + Textbox1.text + ")"
Box1.Backcolor = P1
How can I go about changing the backcolor on the fly?
You could split the text, run the entries though int and feed it to RGB:
Dim A As Variant
A = Split(Textbox1.text,",")
Box1.BackColor = RGB(Int(A(0)),Int(A(1)), Int(A(2)))
Based on your code, Eval() should work for you. The function evaluates a string as if were code. Backcolor is a long, btw so I adjusted your code accordingly.
Dim P1 as Long
P1 = eval("RGB(" + Textbox1.text + ")")
Box1.Backcolor = P1
Or you can ditch P1 and do this:
Box1.Backcolor = eval("RGB(" + Textbox1.text + ")")
Depending on what you are doing, you might just want to use the built in color dialog instead of entering text in a textbox.
Here's the API declaration and re-usable function
Declare Sub wlib_AccColorDialog Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As Long, lngRGB As Long)
Function ChooseColor(nDefColor As Variant) As Long
Dim lngColor As Long
wlib_AccColorDialog Screen.ActiveForm.Hwnd, nDefColor
ChooseColor = nDefColor
End Function
And here would be your box call to these functions; it's passing the default color of the box so that will be chosen when the dialog is open.
Box1.BackColor = ChooseColor(Me.Box1.BackColor)

Access VBA programmatically setting font/size not working

I have a button that is supposed to change the font face and size of a textbox to Tahoma 8pt. The button event is:
Private Sub btnSetFont_Click()
MsgBox ("Setting Inventory Description to Tahoma 8pt")
Me.InventoryDescription.FontSize = 8
Me.InventoryDescription.FontName = "Tahoma"
End Sub
Unfortunately, the text does not change. I'm testing it by first editing the font and size by hand, and then pressing my button.
However, if I do the following,
Private Sub btnSetFont_Click()
MsgBox ("Setting Inventory Description to Tahoma 8pt")
Me.InventoryDescription.Value = "hello"
Me.InventoryDescription.FontSize = 24
Me.InventoryDescription.FontName = "Times"
End Sub
The text changes to "hello" of course, but the font and size do indeed change. (I used Times 24pt because the default for the textbox is Tahoma 8pt and I wanted to make sure it wasn't just reverting to the default) This made me think that the textbox needs to have the focus to make the changes. So, I tried:
Private Sub btnSetFont_Click()
MsgBox ("Setting Inventory Description to Tahoma 8pt")
Me.InventoryDescription.SetFocus
Me.InventoryDescription.FontSize = 24
Me.InventoryDescription.FontName = "Times"
End Sub
But, no go.
Soooo, what am I doing wrong?
I found one aspect to the problem. The text box .TextFormat is set to Rich Text. If I change it to Plain Text, then the button effect works. However, the reason it is set to Rich Text is to allow italics. So, I tried first setting it to plain text, and then changing the font/size, but that didn't work either.
I have the same need: I want the users to be able to format the text with boldface, italics and underlined characters, but I don't want to allow font name changes, or font size changes. And copy/paste actions often import formatted text in my textBox, which needs to be "cleaned".
The solution I found is in the Function below.
This function should be called by an Event Procedure (i.e. After Update, or On Click).
Public Function CleanRichText(strTEXT, strFont, nSize)
'*****************************************************
'
For i = 1 To 9
strTEXT = Replace(strTEXT, "size=" & i, "size=" & nSize)
Next i
strTEXT = Replace(strTEXT, "font face", "font_face")
strTEXT = Replace(strTEXT, "font" & Chr(13) & Chr(10) & "face", "font_face")
Do While InStr(1, strTEXT, "font_face=" & Chr(34)) > 0
iCut1 = InStr(1, strTEXT, "font_face=" & Chr(34))
iCut2 = InStr(iCut1 + 12, strTEXT, Chr(34))
strLeft = Left(strTEXT, iCut1 - 1) & "font_face=Face"
strRight = Right(strTEXT, Len(strTEXT) - iCut2)
strTEXT = strLeft & strRight
Loop
Do While InStr(1, strTEXT, "font_face=") > 0
iCut1 = InStr(1, strTEXT, "font_face=")
iCut2 = InStr(iCut1 + 12, strTEXT, Chr(32))
strLeft = Left(strTEXT, iCut1 - 1) & "font face=" & strFont & Chr(32)
strRight = Right(strTEXT, Len(strTEXT) - iCut2)
strTEXT = strLeft & strRight
Loop
CleanRichText = strTEXT
End Function
Private Sub Cause_AfterUpdate()
Me.Cause = CleanRichText(Me.Cause, Me.Cause.FontName, 2)
End Sub
Your code works for me. Try adding Me.Repaint after changing the font.
Your code worked for me using Access 2010.
I added this code to the click event for a couple command buttons that allow the user to dynamically control the font size in a List box called teachersList.
Private Sub cmdDecreaseFont_Click()
Me.teachersList.FontSize = Me.teachersList.FontSize - 1
End Sub
Private Sub cmdIncreaseFont_Click()
Me.teachersList.FontSize = Me.teachersList.FontSize + 1
End Sub
Then added a couple simple command buttons to the form
I started using the #yves solution but it fails when a "font" tag includes a "size" property, for example:
<font face="Arial" size="5">a colour in it will break?</font>
So I found a better way using #RegExp, you can follow the thread in this forum: accessforums.net
Public Function CleanRichTextRegEx(ByVal strText As String, _
ByVal strFont As String, _
ByVal nSize As Integer) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("VBScript.RegExp")
On Error Resume Next
With objRegEx
.Global = True
'Replace font size
.Pattern = "size=[0-9]"
strText = .Replace(strText, " size=" & nSize)
'Replace font face
.Pattern = "face=([""'])(?:[\r\n]*(?=(\\?))\2.)*?\1"
strText = .Replace(strText, "face=" & strFont)
End With
Set objRegEx = Nothing
CleanRichTextRegEx = strText
End Function
And you can use it in this way:
richText = "<font face='Arial' size='5'>a colour in it will break?</font>"
richTextResult = CleanRichTextRegEx(richText, "Arial", 2)

How to compare the format of text between Excel and Access (like color, bold etc)

In fact, what I am doing now is to realize the synchronization of Excel and Sharepoint, which means that Excel can update with the updating of Sharepoint, and the same for the inverse case.
As known, MS 2003 has no problem with this, but MS 2010 can just realize the fonction from Sharepoint -> Excel, but not the inverse way.
So I am thinking to add Access because there exists Access <-> Sharepoint, and so if I can realize la fonction Excel -> Access, that will solve my problem.
I have finished some parts of macros for this, and now I have realized the fundamental fonction of synchronization. However, there are some difficulties in dealing with the format of text. In Sharepoint and Access, to express the color is like this
<div><font color = "#ff0000">TEXT</font></div>, however in excel I have no idea about the expression of the string.
So how to do it? All suggestions or answers will be appreciated.
This is a very broad question and covers alot of possibilities, and this isn't a complete answer, but for comparing HTML to VBA formatting, you would need to individually break down each formatting option and convert it from HTML to VBA and determine the properties applied to the text, just as you stated above. Then you would need individual VBA functions to specify what you want to compare from the text.
That being said, this is just an example of how this can be achieved for font color comparison.
Given:
'example html: <div><font color = "#ff0000">TEXT</font></div>
Dim HTML_text : HTML_text = "<div><font color = '#ff0000'>TEXT</font></div>"
Dim font_color : fontcolor = Mid(HTML_text, instr(HTML_text, "#"), 7)
Would return "#ff0000" as a variable font_color Then you would need the excel function to convert Hex(#FF0000) to RGB (taken from -> Here):
Public Function HEXCOL2RGB(ByVal HexColor As String) As String
Dim Red As String
Dim Green As String
Dim Blue As String
Color = Replace(HexColor, "#", "")
Red = Val("&H" & Mid(HexColor, 1, 2))
Green = Val("&H" & Mid(HexColor, 3, 2))
Blue = Val("&H" & Mid(HexColor, 5, 2))
HEXCOL2RGB = Red & "," & Green & "," & Blue
End Function
Then to extract the fonts RGB in Excel to the RGB you recieved from HTML you would need the following function(taken from -> Here):
Function FontColorRGB(Target As Range) As String
Dim N As Double
N = Target.Font.Color
FontColorRGB = Str(N Mod 256) & "," & Str(Int(N / 256) Mod 256) & "," & Str(Int(N / 256 / 256) Mod 256)
End Function
Then to finally pull it all together, you would utilize both functions:
Dim XLFontClr : XLFontClr = FontColorRGB("A1:A2")
Dim RGB_clr : RGB_clr = HEXCOL2RGB(font_color) 'Returns "Red,Green,Blue" in string form.
If XLFontClr = RGB_clr Then
msgbox "web formatting and excel formatting compared successfully"
End If