Say I have the following code within a sub:
With square
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.Transparency = 1
.Name = "Foo"
End With
I can now define searches based on its .Name and even use that name within the code (for instance, I could set some String value to the name of the shape).
My question is - is there another way for me to store values 'within' a shape? Specifically, multiple Strings and Integers.
If no, when I am setting the text of a shape based on some String and Integer variables within a Sub, is there a way to allow a different Sub to use those bits of information?
You may use square.tags collection - square.tags.Add "NAME",VALUE
There is an example
With square
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.Transparency = 1
.Name = "Foo"
.Tags.Add "Tag 1", 1
.Tags.Add "Tag 2", 2
' Reading
For a = 1 To .Tags.Count
Debug.Print .Tags.Name(a), .Tags.Value(a)
Next a
End With
Related
I would like to write a Word VBA macro that inserts a vertical line the length of the selected text.
apos = Int(Selection.Information(6))
Set aLine = ActiveDocument.Shapes.AddLine(26, apos, 26, apos + 40)
aLine.Select
With Selection
.ShapeRange.Line.Weight = 3#
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
But that code adds the vertical line length of "40"
How do I adjust the length "40" to be the length of the selected text?
Thank you
Use exactly the same method by which you have determined the beginning of the line. The end is at the Information(wdHorizontalPositionRelativeToPage) of the last character in the Selection + 1. Here is the complete code.
Private Sub LineUnderSelection()
' 08 May 2017
Dim Rng As Range
Dim FontHeight As Single, ParaSpace As Single
Dim LineStart As Single, LineEnd As Single
With Selection
With .Range
Do While Asc(.Text) < 48
' remove excluded characters at start
.MoveEnd wdCharacter, 1
Loop
Do While Asc(Right(.Text, 1)) < 48
' remove excluded characters at end
.MoveEnd wdCharacter, -1
Loop
LineStart = .Information(wdHorizontalPositionRelativeToPage)
Set Rng = Selection.Range
Rng.SetRange .End, .End
FontHeight = Int(Rng.Font.Size)
ParaSpace = 2 - Rng.Paragraphs(1).SpaceBefore
If ParaSpace < -3 Then ParaSpace = -3
LineEnd = Rng.Information(wdHorizontalPositionRelativeToPage)
SetLine ActiveDocument, "Underscore", LineStart, LineEnd - LineStart, _
.Information(wdVerticalPositionRelativeToPage) _
+ FontHeight + ParaSpace, 1.5, vbRed
End With
End With
End Sub
As you see, I found out that the extra character isn't needed. Word extends the line to the end of the character automatically. In the process of finding this out I also discovered that Word doesn't like to underline returns. Therefore the code excludes all characters with an ASCII code of less than 48 (represents the character 1). I then applied the same rule to leading characters, likewise removing them from the selection. Please run your own tests if this is enough or too much. There are lots of characters with a code > 128 which might be offensive.
The code takes the size of the last character and adds its height to the vertical position. This is to place the line under the selected text, not above it. I added 2 points to keep a little space between the text and the line.
Word takes note of space before. Your selection might contain several paragraphs. My code only looks at the paragraph of which the last character is a member. Word seems to place the line about 3 points lower if there is SpaceBefore in the paragraph's format, almost regardless of how big that space is. But if the space is smaller than 3pt the line will be lowered correspondingly less. This examination led to this code.
ParaSpace = 2 - Rng.Paragraphs(1).SpaceBefore
If ParaSpace < -3 Then ParaSpace = -3
You may like to amend this code to place the line more precisely. You will see that the vertical position consists of the position of the selection + FondtSize + ParaSpacing.
All of the above code creates the parameters which are fed to another sub which creates the actual line. Observe that the parameters include the line width and setting the Activedocument as target and giving a name to the line. It is possible to give the same name repeatedly. Word will use its own names in additon, and they are unique. Here is the code that inserts the line. (You may prefer to make it Private)
Function SetLine(Story As Object, _
Lname As String, _
Lleft As Single, _
Llength As Single, _
Ltop As Single, _
Lwidth As Single, _
Lcol As Long) As Shape
' 20 Aug 2016
Dim Fun As Shape
Set Fun = Story.Shapes.AddLine(Lleft, Ltop, Lleft + Llength, Ltop)
With Fun
.Title = Lname
.Name = Lname
.LockAspectRatio = msoTrue
With .Line
.Weight = Lwidth
.ForeColor = Lcol
End With
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Visible = msoTrue
.WrapFormat.AllowOverlap = msoTrue
.LayoutInCell = msoFalse
.ZOrder msoSendBehindText
.LockAnchor = msoTrue
End With
Set SetLine = Fun
End Function
This code includes a lot of parameters which are not variable by means of the arguments it receives, such as LockAnchor, ZOrder etc. You may wish to change these to better meet your requirements.
I'm using the following code alot in my project:
txtVoornaam.Locked = False
txtVoornaam.BorderStyle = 4
txtVoornaam.BorderColor = RGB(255, 165, 0
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
txtAfdeling.Locked = False
txtAfdeling.BorderStyle = 4
txtAfdeling.BorderColor = RGB(255, 165, 0)
I wonder if there is a way to not display this in my code or shorten this. The code gets very long if i use this a few times..
Whenever you need to repeat a set of instructions, instead of copy+pasta'ing code your first reaction should be to ask yourself "how can I avoid copying this chunk over and over?" - and the solution is pretty much always to extract a method and parameterize it.
So you take one of the repeated chunks:
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
and then copy it one last time in a new scope:
Private Sub RenameMe()
txtAchternaam.Locked = False
txtAchternaam.BorderStyle = 4
txtAchternaam.BorderColor = RGB(255, 165, 0)
End Sub
Then you extract the parameters:
Private Sub RenameMe(ByVal target As Control)
target.Locked = False
target.BorderStyle = 4
target.BorderColor = RGB(255, 165, 0)
End Sub
Then you replace the repeated chunks with calls to that new procedure:
RenameMe txtVoornaam
RenameMe txtAchternaam
RenameMe txtAfdeling
Or if that's still tedious you can iterate controls and call that procedure in the loop body - whatever works best for you.
And if you need more flexibility, extract more parameters and make them Optional as needed:
Private Sub RenameMe(ByVal target As Control, Optional ByVal lockCtrl As Boolean = False, Optional ByVal brdrStyle As Long = 4, Optional ByVal brdrColor As Long = 42495)
target.Locked = lockCtrl
target.BorderStyle = brdrStyle
target.BorderColor = brdrColor
End Sub
Now the hard part is to give RenameMe a meaningful name that properly conveys what's going on here. I'd suggest FormatControl or something along these lines.
An option if you have several controls that you are creating through a form would be to do the following:
Dim names() As String
names = Split("txtVoornaam,txtAchternaam,txtAfdeling", ",")
Dim ctrl As Variant
Dim ctrlName As Variant
For Each ctrl In Me.Controls
For Each ctrlName In names
If StrComp(ctrlName, ctrl.Name) = 0 Then
ctrl.Locked = False
ctrl.BorderStyle = 4
ctrl.BorderColor = RGB(255, 165, 0)
End If
Next ctrlName
Next ctrl
This code iterates through each of the control names that fit your list.
However, this is much less efficient than Mat's Mug's answer because you are iterating through the entire list of controls in your form, but it does showcase how you might take a list of static names and iterate through them and a collection.
If you wanted to change all the text controls this would be the way to do it; simply remove the ctrlName check.
As Parfait has correctly pointed out, you could shorten the code to the following if you are confident in your control names:
Dim names() As String
names = Split("txtVoornaam,txtAchternaam,txtAfdeling", ",")
Dim ctrlName As Variant
For Each ctrlName In names
With Me.Controls(ctrlName)
.Locked = False
.BorderStyle = 4
.BorderColor = RGB(255, 165, 0)
End With
Next ctrlName
function Lockdown(strControl)
with me(strControl)
.locked = false
.borderstyle = 4
.bordercolor = RGB(255,165,0)
end with
use me or forms!formname depending on where you're calling from
if your controls are the same, obviously put them in a single sub/function that you can call from anywhere. i would not try to lock or change the format of textboxes, instead just enable/disable, and it will handle the format for you:
textbox.enabled = true/false
if you are doing this on multiple forms and really want a single sub/function to control enabling/disabling the textboxes on each form, then there are various ways of doing that as well, solution will depend on your needs, but certainly doable and some have already commented above.
for example, you can use the "tag" property of the textboxes to flag the textboxes on that form that you want to enable/disable. you can then have a single sub/function that would take in the form as reference, and then you can read the "tag" property of all textboxes on that form and if they are the ones you flagged, you would proceed to enable/disable them
I'm trying to use Excel VBA to control text box background colors depending on the values in certain cells. Each text box corresponds to a different cell with a value in it. I have about 60 text boxes to control and 4 possible colors for each one. Using switch statements, I would basically have to do 4 cases for each of the 60 text boxes... Assuming I use the way I have it set up now as seen below:
Select Case Cells(50, 2).Value
Case Is = 1, 6, 11, 16
.TextBox13.BackColor = RGB(0, 255, 0)
Case Is = 5
.TextBox13.BackColor = RGB(255, 0, 0)
Case Is = 0
.TextBox13.BackColor = RGB(255, 255, 255)
Case Is = 10, 15
.TextBox13.BackColor = RGB(255, 255, 0)
End Select
And so on for all 60. However, the value range is always the same, and the colors correspond with the same values for each one. I'm assuming there must be a way to build one module to actually set the colors, and just use switch statements to determine with cell to send to that module?
EDIT: I've attached a screenshot of the workspace so you can see what I'm going for
Some piece of your code is wrong. It's Select Case ... End Select
Select Case Cells(50, 2).Value
Case 1, 6, 11, 16
tbxObject.BackColor = RGB(0, 255, 0)
Case 5
tbxObject.BackColor = RGB(255, 0, 0)
Case 0
tbxObject.BackColor = RGB(255, 255, 255)
Case 10, 15
tbxObject.BackColor = RGB(255, 255, 0)
End Select
Please, see: Select ... Case statement
If some piece of code is used several times, you have to move it into single general soubroutine, which can accept TextBox object as input parameter.
Sub ColorMyTextBox(wsh As Worksheet, sTextBoxName As String)
Dim txtObject As OleObject
Set txtObject = wsh.OleObjects(sTextBoxName)
If TypeName(txtObject) <> "TextBox" Then Goto Exit_Sub
'here Select Case statement
Exit_Sub:
End Sub
Got it?
Ok, so if I use that, how will I specify the cell numbers to use in the case statements? It won't always be cells(50,2)... And I also get errors when sending the worksheet name
I am trying to change the font color based on the values in the cells(16,3).
For some reason it is not working. The present value at 16,3 is 94% and it is showing up in green color instead of amber. Your help would be appreciated.
Private Sub TextBox1_Change()
TextBox1.Value = Cells(16, 3).Text
Cells(16, 3).Font.Bold = True
If TextBox1.Value > 95 Then TextBox1.ForeColor = RGB(0, 128, 0) 'Green
If TextBox1.Value > 80 And TextBox1.Value < 95 Then TextBox1.ForeColor = RGB(255, 153, 0) 'Amber
If TextBox1.Value < 80 Then TextBox1.ForeColor = RGB(255, 0, 0) 'Red
End Sub
You'll get that result if the value in the cell is in text format rather than as an actual value. Is it possible that that's the case?
The other thing to bear in mind, though this wouldn't be the cause of your existing problem or the text would always be red, is that 94% is actually 0.94, not 94.
Edit: (I'm doing an edit to my original answer in response to the comment because I need to include code which does not go into comments well)
You have a few other problems.
The first is that if this is being driven by the value in cell(16,3) I'm not sure that you should be driving it from the Textbox1_Change event. By doing that you are waiting for someone to enter a value into that text box and immediately overwriting it with whatever is in that cell. Better to populate the entry during the form load.
Much depends on what you're trying to do with this, and I have no information on that.
Second, if you step through the code you'll find that TextBox1.Value is returning a string; it has double quotes around it. But you are comparing it to a numeric set of values.
The third is that your code does not deal with the situation where there is an exact match of (say) 80%.
The fourth is that if you suck the value straight from the cell, and it really is a percentage value, it'll come up as 0.94, not formatted as a percentage.
This deals with the lot.
Dim rng As Excel.Range
Set rng = ActiveSheet.Cells(16,3)
TextBox1.Value = Format(rng.Value, "00%")
rng.Font.Bold = True
'You should really implement error checking here.
'There's no point reading the value from the textbox if it's coming from a cell.
'Just use the cell value.
If rng.Value >= 0.95 Then
TextBox1.ForeColor = RGB(0, 128, 0) 'Green
ElseIf rng.Value >= 0.8 And rng.Value < 0.95 Then
TextBox1.ForeColor = RGB(255, 153, 0) 'Amber
ElseIf rng.Value < 0.8 Then
TextBox1.ForeColor = RGB(255, 0, 0) 'Red
End If
Set rng = Nothing
If you use
TextBox1.Value = Cells(16, 3).Value
instead of
TextBox1.Value = Cells(16, 3).Text
You will see the real values used in your if statements. And result will be like below:
If Text Type of related cell is : "General"
And if you use related cell type as "Percentage". You will get following results
So, depending on your preferences you can either use the cell value as general or you can convert it in the macro from percentage to general and display it as it is.
If you want to keep using Percentage in your related sheet which means actually as value you will have 0.XX in that cell however it will display as XX%, then you can simply multiply your value with 100 as follows:
TextBox1.Value = Cells(16, 3).Value * 100
Im Creating a subroutine as below to Refer a Cell and coulor the shape.
In my Code the H value (Name) is not working. Please help.
Sub Erectioncolour()
J = 9
H = 1
Do
If Worksheets("Vertical Chart").Cells(J, 25).Value <> "" Then
Worksheets("Visual Chart").Shapes(H).Fill.ForeColor.RGB = RGB(5, 0, 0)
Else
Worksheets("Visual Chart").Shapes(H).Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
J = J + 1 And H = H + 1
Loop While J = 268
End Sub
In my Code the H value (Name) is not working.
Yes, it is actually working.
Your problem is with the conditional If Worksheets("Vertical Chart").Cells(J, 25) <> "". Row 25 in that worksheet is empty, after column K. So for every value of J greater than 10, it will not apply the RGB(5, 0, 0), but instead applies the RGB(255, 255, 255) as the False part of the test.
So the True part of your If/Else statement is only being executed once. After that, they all evaluate to False, so the shapes are being correctly (according to the code) applied with the following from your Else statement:
Worksheets("Visual Chart").Shapes(H).Fill.ForeColor.RGB = RGB(255, 255, 255)
Solution:
You need to change your logic in the If statement, or, specify a non-white RGB value.
Updated to explain how IF statements work...
THere are two parts to your If statement, a True part which colors the shapes with RGB(5, 0, 0) and a False part which colors the shapes with RGB(255, 255, 255) (white). As your file is currently configured, the statement evaluates False for every value of J in {9,11,12,..., 268}. This is conditional based on the logic AND the data (or lack thereof) in the worksheet.
If you don't want these shapes to be white, then you need to assign a different RGB value. Which one you choose is up to you, for example .RGB(6, 255, 255) looks turquoise.
Or the other possibility is that your If statement's test is incorrect. If that is not correct, then I cannot help you until you describe how the test should be working, because the current test will always do what it is doing right now, until the cells in Row 25 are non-blank.