I would like to change the character spacing to the selected text from the paragraph. But my below code change the character spacing for the entire text box. Can anyone help me with this.
For e.g., I just need to increase the character spacing only for the selected text from the entire sentence. Shown in the below picture
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Font.Spacing = 3
Also below code can help me with my purpose. But here the issue is, how can i get the 20 and 45 from the macro.
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Characters(20, 45).Font.Spacing = 3
Your code:
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Font.Spacing = 3
refers to the entire text range of the selected shape. Instead, use:
ActiveWindow.Selection.TextRange2.Font.Spacing = 3
This will act only on the selected text.
You will need to loop over the string and check the character font format for each letter, marking the beginning and end of any bold section of text, then use those positions to apply the spacing:
Dim shp As Shape, i As Long, pStart As Long, n As Long
Set shp = ActivePresentation.Slides(1).Shapes(1)
pStart = 0
With ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange
n = .Characters.Count
For i = 1 To n
If .Characters(i, 1).Font.Bold Then
If pStart = 0 Then
pStart = i
ElseIf pStart > 0 And i = n Then 'ending on bold text
.Characters(pStart, i - pStart).Font.Spacing = 3
End If
Else
If pStart > 0 Then 'transitioning to non-bold
.Characters(pStart, i - pStart).Font.Spacing = 3
pStart = 0
End If
End If
Next i
End With
Related
I have a richtextbox and i have put a long sentences. Its wordwrap is on. Because of this it shows 4 lines. I want to show the width of each line separately.
I have tried with richtextbox1.lines.length, but it is showing: 1
I have tested this code briefly and I think that it does what you want. It will include carriage return and line break characters in the count I think, so you will have to handle that explicitly if you need different.
Dim previousFirstCharIndex = 0
Dim lineIndex = 1
Dim firstCharIndex = RichTextBox1.GetFirstCharIndexFromLine(lineIndex)
Dim lineLengths As New List(Of Integer)
Do Until firstCharIndex = -1
lineLengths.Add(firstCharIndex - previousFirstCharIndex)
previousFirstCharIndex = firstCharIndex
lineIndex += 1
firstCharIndex = RichTextBox1.GetFirstCharIndexFromLine(lineIndex)
Loop
lineLengths.Add(RichTextBox1.TextLength - previousFirstCharIndex)
MessageBox.Show(String.Join(Environment.NewLine, lineLengths), "Line Lengths")
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 have cells in a sheet that include a bunch of text, but also have certain text within square brackets that look like this:
[Assign: some text here]
[Select: some text here]
I need a macro that will change the color of any text starting with Assign to green (including Assign) and any text starting with Select to blue (also including Select). Brackets themselves could be color changed or not, whatever is easiest.
I have tried multiple ways to do this but cannot figure out with a regex or a replace how to do this. Closest I have come was uppercasing all text within [] brackets but not making a distinction between Assign or Select.
Appreciate the help
Edit:
What I have so far:
Sub test()
Dim r As Range
Dim m As Object
Dim test As Range
Dim strInput As String
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.Pattern = "\[(.*?)\]"
For Each r In Range("C2:C2")
If .test(r.Value) Then
For Each m In .Execute(r.Value)
r.Value = Replace(r.Value, m.Value, UCase(m.Value))
Next
End If
Next
End With
End Sub
Range(SomeRange).Characters(start,length).Font.Color = vbGreen
To get your start and length, use Instr
start = Instr(1, Range(SomeRange).Value, "[Assign", vbTextCompare)
length = Instr(start, Range(SomeRange).Value, "]", vbTextCompare) - start + 1
If start is zero then string not found.
--
UPDATE:
Off top of my head, for multiple instances in the same cell:
start = 1
Do
start = Instr(start, Range(SomeRange).Value, "[Assign", vbTextCompare)
If start > 0 Then
length = Instr(start, Range(SomeRange).Value, "]", vbTextCompare) - start + 1
if length > 1 then Range(SomeRange).Characters(start, length).Font.Color = vbGreen
start = start + length
End If
Loop While start > 0
What I want to do is create a macro to look at a column (AF) and based on that value, compare column (BI), (BJ), and/or (BK) together and if its false, highlight the compared cells in yellow. I know that's a little hard to follow but this example should help clarify:
My Sheet has the following columns:
Column AF Column BI Column BJ Column BK
PRODUCT Height Length Width
I need a macro to look at the product type and compare the dimensions for that product as follows:
- If product = A, then Length = Width, if not then highlight Length and Width Cells
- If product = B then Length > Width, if not then highlight Length and Width Cells
- If product = C then Width > Height < Length, if not highlight Length, Width, and Height cells
- If product - D then Width = Length < Height, if not highlight Width, Length, and/or Height
My Data starts on row 3 and ends at row 5002.
I have tried researching this and was only able to find solutions that compare two cells then write a third column. I could combine an IF formula and conditional formatting to achieve this but I don't want to have this run all the time as the sheet will be sorted and color coded. I plan to place this macro into a command button.
Suggest to combine Statements such as Select Case, If...Then...Else, together with Operators And, Or. See the following pages:
https://msdn.microsoft.com/en-us/library/office/gg251599.aspx
https://msdn.microsoft.com/en-us/library/office/gg278665.aspx
https://msdn.microsoft.com/EN-US/library/office/gg251356.aspx
After which you should be able to write something that resembles this:
(Code below is just a sample, it will not work)
Select Case Product
Case A
If Length <> Width Then
Rem Highlight Length And Width Cells
End If
Case B
If Length <= Width Then
Rem Insert here the code to highlight Length And Width Cells
End If
Case C
If Width <= Height And Height >= Length Then
Rem Insert here the code to highlight Length, Width, and Height cells
End If
Case D
If Width <> Length And Length >= Height Then
Rem Insert here the code to highlight Width, Length, and/or Height
End If
End Sub
In case you don’t know to highlight the Width, Length and Height Cells; I suggest to do it manually while recording a macro, this shall give a good starting point.
I suggest to work with objects, defining variables for the Data range, each row being validated, the position of the fields to validate, etc. see below code with comments
Sub Highlight_Cells_based_Comparison()
Dim rData As Range
Dim rRow As Range
Dim rCllsUnion As Range
Rem Set variables to hold Fields position within the DATA range
Dim bPosProd As Byte, bPosHght As Byte, bPosLeng As Byte, bPosWdth As Byte
Rem Set variables to hold Fields values
Rem (data type Variant as don't know type of values these fields are holding, change as appropriated)
Rem see https://msdn.microsoft.com/en-us/library/office/gg251528.aspx)
Dim sProd As String, vHght As Variant, vLeng As Variant, vWdth As Variant
Dim lRow As Long
Rem Set Range (assuming it goes from column C to BK - change as needed)
Rem Not starting from column A on porpuse
Set rData = ActiveSheet.Range("C3:BK5002")
Rem Get Fields position from Header row
Rem Suggest to use this method instead of hard coding columns
On Error Resume Next
With rData
bPosProd = WorksheetFunction.Match("PRODUCT", .Rows(1), 0)
bPosHght = WorksheetFunction.Match("Height", .Rows(1), 0)
bPosLeng = WorksheetFunction.Match("Length", .Rows(1), 0)
bPosWdth = WorksheetFunction.Match("Width", .Rows(1), 0)
End With
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
Rem Loop thru each row excluding header
For lRow = 2 To rData.Rows.Count
Set rRow = rData.Rows(lRow)
With rRow
Rem Get Row Field values
sProd = .Cells(bPosProd).Value2
vHght = .Cells(bPosHght).Value2
vLeng = .Cells(bPosLeng).Value2
vWdth = .Cells(bPosWdth).Value2
Select Case sProd
Case A 'Change value of A as required
Rem If product = A, then Length = Width, if not then highlight Length and Width Cells
Rem If Length <> Width Then Highlight Length And Width 'Cells
If vLeng <> vWdth Then
Set rCllsUnion = Union(.Cells(bPosLeng), .Cells(bPosWdth))
Rem Suggest to use a subroutine for this piece as it's a repetitive task
Rem see https://msdn.microsoft.com/en-us/library/office/gg251648.aspx
GoSub CllsUnion_Highlight
End If
Case B
Rem repeat as in Case A with required changes
Case C
'...
Case D
'...
End Select: End With: Next
Exit Sub
Rem Subroutine to highlight cells
CllsUnion_Highlight:
With rCllsUnion.Interior
.Color = 65535
.TintAndShade = 0
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.PatternTintAndShade = 0
End With
Return
End Sub
Recently we upgraded one our PowerPoint addin to support 2007 and 2010. most of the items we were able to port without problem. one problem we have is that indentations doesn't work when create tables or shapes using the addin.
for eg: same table gets dropped with proper indentation in 2003 but same thing doesn't get indentation when added to using 2007.
below is the code snippet that allows indenting:
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.Ruler
For rulerCount = 0 To 5
.Levels(rulerCount).FirstMargin = rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Levels(rulerCount).LeftMargin = rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
any idea why this is not working ?
I read the following thread too but didn't help much http://answers.microsoft.com/en-us/office/forum/office_2007-customize/why-shapetextframerulerlevelsi-cant-set-the-bullet/9eac3e46-b13b-433e-b588-216ead1d9c1a?tab=AllReplies#tabs
Updated Code:
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = "N/A"
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame
'Dim rulerCount As Short
For rulerCount = 1 To 5
.Ruler.Levels(rulerCount).FirstMargin = 10 * rulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(rulerCount).LeftMargin = 20 * rulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = text
FWIW, in 2007 and up, you can now have up to 9 ruler levels instead of 5 as in earler versions. But your code should work as is. Here's a simplified version that does work on an arbitrary cell (2,2) of a table:
Dim oSh As Shape
Dim x As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.Table.Cell(2, 2).Shape.TextFrame
For x = 1 To 9
.Ruler.Levels(x).LeftMargin = x * 10
.Ruler.Levels(x).FirstMargin = x * 20
Next
End With
The other thing you might be running into is that you can apply certain types of formatting (including ruler settings) all you like; if there's no text at the level you're applying it to, PPT won't bark. It'll ignore you. Your settings will have no effect. Sometimes you need to check for text, supply some if there's none there (something highly improbable in the real world) then delete all instances of your improbable text afterwards.
Ugly. Yes.
Here we add text and set indent levels before trying to FORMAT each indent level:
Sub test()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
Dim RulerCount As Long
Dim sTemp As String
sTemp = "##$%" ' dummy text
With oSh.Table.Cell(2, 3).Shape.TextFrame
For RulerCount = 1 To 5
.TextRange.Paragraphs(RulerCount).Text = sTemp & vbCrLf
.TextRange.Paragraphs(RulerCount).IndentLevel = RulerCount
Next
For RulerCount = 1 To 5
.Ruler.Levels(RulerCount).FirstMargin = 10 * RulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(RulerCount).LeftMargin = 20 * RulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next RulerCount
End With
End Sub