I thought the two following programs would be identical, why arent they?
This code works:
For i = 1 To n
Set r = Selection.Range.Paragraphs(i).Range
r.Collapse
r.Text = " "
r.ContentControls.Add (wdContentControlCheckBox)
Next i
This code doesn't:
For i = 1 To n
Set r = Selection.Range.Paragraphs(i).Range
Set p = r.Paragraphs(1)
p.Range.Text = " " + p.Range.Text
r.Collapse
r.ContentControls.Add (wdContentControlCheckBox)
Next i
As far as I can tell, the only difference is instead of concatenating the old text behind a space then placing the cursor at the start of the para, I just place the cursor at the start of the para and input a space.
Tl;dr: I don't understand why the two programs above aren't equivalent
I lack the general knowledge to google the reason. My attempts pulled up general purpose guides. I tried stepping through the debugger to get a grasp of the control flow, but that didn't help either.
Try:
Dim sel As Range
Set sel = Selection.Range
For i = 1 To n
Set r = Selection.Range.Paragraphs(i).Range
Set p = r.Paragraphs(1)
p.Range.Text = " " + p.Range.Text
r.Collapse
r.ContentControls.Add (wdContentControlCheckBox)
sel.Select
Next i
The problem is that:
p.Range.Text = " " + p.Range.Text
is changing the selection....
**** Edited to include better explanation****
When you use r.Collapse - you are setting the range r to have equal start and end positions.
For example if you have a paragraph like so:
"This is my first paragraph"
when you set r, it has a start of 0 and an end of 27. After you run r.Collapse the start and end both become 0 (assuming the para is at the start of the document).
You then insert a space (under your first method) at position 0 and then add your content control. Word can cope with this whilst the selection is selected.
Under the second method, you are changing the text of a paragraph directly. You are collapsing r later, but that will not change p. P will be range 0,27 to start. Word cannot change range (0,27) to be (0,28) by adding the space without selecting it.
In short, the difference is the collapse causing Word being able to insert the space before what is (to Word) a null range at that time.
Related
I have a text document in Word with several parts, I have created my table of contents. I created a TOC to be able to update it automatically, it is used for that.
By alt+F9 I have TOC \O "1-2" \H \U
You can see the sign \H that I need to have the links to the headers.
I can in the headers apply the desired color before and after the two points of my titles which are the form :
[xxxxx xxxx xxxx : (red)] [yyyyy yyyyy yyyyy (black)]
I want this color difference to show up in my summary (TOC) as well. So I add the instruction \* MERGEFORMAT
This gives : TOC \O "1-2" \* MERGEFORMAT \H \U
However, by doing this, I lose my links, as the instruction \H is no longer valid.
So I switched to VBA code.
But I don't know how to say :
xxxxxxx (in red) : xxxxxx (in black)
The x is variable, and the two points ( : ) is always present in my titles in the headers.
What would be the code to say that from the 2 points ( : ) the rest of the titles must be in black color. OR that before the 2 points ( : ) the color of the titles must be in red ?
For example:
Example/title: (in red) Here is my title (in black)
Example title two: (in red) Here is my second example (in black)
Other/example/additional: (in red) This is the last title (in black)
Thank you for your insights
EDIT :
Hi,
`Dim I As Integer, J As Integer
Dim MonTableau As Variant
Dim ListePositionsMots As String
Dim MonRange As Range
With ActiveDocument
If .TablesOfContents.Count = 0 Then
MsgBox "Aucune table des matières dans le document !", vbInformation
Exit Sub
End If
With .TablesOfContents(1)
J = 1
For I = 1 To .Range.Words.Count
If J <= 2 Then
If .Range.Words(I) <> "" Then ListePositionsMots = ListePositionsMots & I & ","
J = J + 1
End If
If .Range.Words(I) = Chr(13) Then J = 1
Next I
ListePositionsMots = Mid(ListePositionsMots, 1, Len(ListePositionsMots) - 1)
MonTableau = Split(ListePositionsMots, ",")
For I = LBound(MonTableau) To UBound(MonTableau)
Set MonRange = ActiveDocument.TablesOfContents(1).Range
MonRange.SetRange Start:=MonRange.Words(MonTableau(I)).Start, End:=MonRange.Words(MonTableau(I)).End
With MonRange
If .Text <> Chr(9) Then
.Font.ColorIndex = wdRed
.Case = wdUpperCase
End If
End With
Set MonRange = Nothing
Next I
End With
End With`
Good evening,
The above code works very well and allows me to colour the first 2 words of each of my titles in my table of contents.
x y (red) : x y z (black)
v w (red) : y z (black)
So it's possible.
As sometimes my titles exceed 2 words, I have to modify it.
I have to put the value of the word ; in this case the 2 points caracters ( : ) and not its position.
x y z (red) : (red or black) x y z (black)
But I don't know what vba code can do that, that's why I'm asking on this forum, I'm sure someone can help me?
Thanks.
EDIT 2 (26/05/2021 10:45) : I repeat, I just need the VBA code, nothing more, nothing less... Thanks.
You don't need any code for this. Without the \H switch, a Table of Contents will automatically reproduce any font colouring you apply to a Heading. At most, all you need to do is to refresh the Table of Contents.
Even without the \H switch, your Table of Contents will link to the referenced content via the page #s. All the \H switch does is enable the linking from the Table of Contents text.
In any event, it would be a waste of time trying to apply colouring to the Table of Contents with VBA (or manually), since anything that causes the Table of Contents to refresh (e.g. a print preview or printing the document) will erase all that colouring.
In any event, you don't even need a macro to colour the Table of Contents as you describe - all you need is a single wildcard Find/Replace operation on the Table of Contents, where:
Find = [!^t^13]#:
Replace = ^&
and you set the replacement colour to red. You could, of course, implement that as a macro, but I can't see why anyone would bother...
The code below will apply the color you require. To capitalise the TOC you should modify the font for your TOC styles to AllCaps
Sub ColorTOC()
Dim tocRange As Range
With ActiveDocument
If .TablesOfContents.Count = 0 Then
MsgBox "Aucune table des matières dans le document !", vbInformation
Else
With .TablesOfContents(1)
Set tocRange = .Range.Duplicate
tocRange.Collapse wdCollapseStart
Do Until tocRange.End = .Range.End
tocRange.MoveEndUntil ":"
tocRange.MoveEnd wdCharacter, 1
With tocRange
If .Text <> Chr(9) Then
.Font.ColorIndex = wdRed
End If
End With
tocRange.Collapse wdCollapseEnd
tocRange.MoveUntil vbCr
tocRange.Move wdCharacter, 1
Loop
End With
End If
End With
End Sub
When a TOC is updated the dialog below is displayed.
Choosing the first option will not cause the formatting to be lost, but the TOC will not include any newly added headings. The second option will include any newly added headings, but it will also remove the formatting.
If the document has the "Update fields before printing" option set (it should to ensure that page numbers etc. are correct) then the user will be prompted to update the TOC. This will occur both prior to printing and exporting as PDF. To ensure that your TOC has the correct formatting you will need to write code to respond to the DocumentBeforePrint event so that you can reapply the formatting.
I'm trying to manipulate some text from a MS Word document that includes hyperlinks. However, I'm tripping up at understanding exactly what Range.Start and Range.End are returning.
I banged a few random words into an empty document, and added some hyperlinks. Then wrote the following macro...
Sub ExtractHyperlinks()
Dim rHyperlink As Range
Dim rEverything As Range
Dim wdHyperlink As Hyperlink
For Each wdHyperlink In ActiveDocument.Hyperlinks
Set rHyperlink = wdHyperlink.Range
Set rEverything = ActiveDocument.Range
rEverything.TextRetrievalMode.IncludeFieldCodes = True
Debug.Print "#" & Mid(rEverything.Text, rHyperlink.Start, rHyperlink.End - rHyperlink.Start) & "#" & vbCrLf
Next
End Sub
However, the output between the #s does not quite match up with the hyperlinks, and is more than a character or two out. So if the .Start and .End do not return char positions, what do they return?
This is a bit of a simplification but it's because rEverything counts everything before the hyperlink, then all the characters in the hyperlink field code (including 1 character for each of the opening and closing field code braces), then all the characters in the hyperlink field result, then all the characters after the field.
However, the character count in the range (e.g. rEverything.Characters.Count or len(rEverything)) only includes the field result if TextRetrievalMode.IncludeFieldCodes is set to False and only includes the field code if TextRetrievalMode.IncludeFieldCodes is set to True.
So the character count is always smaller than the range.End-range.Start.
In this case if you change your Debug expression to something like
Debug.Print "#" & Mid(rEverything.Text, rHyperlink.Start, rHyperlink.End - rHyperlink.Start - (rEverything.End - rEverything.Start - 1 - Len(rEverything))) & "#" & vbCrLf
you may see results more along the lines you expect.
Another way to visualise what is going on is as follows:
Create a very short document with a piece of text followed by a short hyperlink field with short result, followed by a piece of text. Put the following code in a module:
Sub Select1()
Dim i as long
With ActiveDocument
For i = .Range.Start to .Range.End
.Range(i,i).Select
Next
End With
End Sub
Insert a breakpoint on the "Next" line.
Then run the code once with the field codes displayed and once with the field results displayed. You should see the progress of the selection "pause" either at the beginning or the end of the field, as the Select keeps "selecting" something that you cannot actually see.
Range.Start returns the character position from the beginning of the document to the start of the range; Range.End to the end of the range.
BUT everything visible as characters are not the only things that get counted, and therein lies the problem.
Examples of "hidden" things that are counted, but not visible:
"control characters" associated with content controls
"control characters" associated with fields (which also means hyperlinks), which can be seen if field result is toggled to field code display using Alt+F9
table structures (ANSI 07 and ANSI 13)
text with the font formatting "hidden"
For this reason, using Range.Start and Range.End to get a "real" position in the document is neither reliable nor recommended. The properties are useful, for example, to set the position of one range relative to the position of another.
You can get a somewhat more accurate result using the Range.TextRetrievalMode boolean properties IncludeHiddenText and IncludeFieldCodes. But these don't affect the structural elements involved with content controls and tables.
Thank you both so much for pointing out this approach was doomed but that I could still use .Start/.End for relative positions. What I was ultimately trying to do was turn a passed paragraph into HTML, with the hyperlinks.
I'll post what worked here in case anyone else has a use for it.
Function ExtractHyperlinks(rParagraph As Range) As String
Dim rHyperlink As Range
Dim wdHyperlink As Hyperlink
Dim iCaretHold As Integer, iCaretMove As Integer, rCaret As Range
Dim s As String
iCaretHold = 1
iCaretMove = 1
For Each wdHyperlink In rParagraph.Hyperlinks
Set rHyperlink = wdHyperlink.Range
Do
Set rCaret = ActiveDocument.Range(rParagraph.Characters(iCaretMove).Start, rParagraph.Characters(iCaretMove).End)
If RangeContains(rHyperlink, rCaret) Then
s = s & Mid(rParagraph.Text, iCaretHold, iCaretMove - iCaretHold) & "" & IIf(wdHyperlink.TextToDisplay <> "", wdHyperlink.TextToDisplay, wdHyperlink.Address) & ""
iCaretHold = iCaretMove + Len(wdHyperlink.TextToDisplay)
iCaretMove = iCaretHold
Exit Do
Else
iCaretMove = iCaretMove + 1
End If
Loop Until iCaretMove > Len(rParagraph.Text)
Next
If iCaretMove < Len(rParagraph.Text) Then
s = s & Mid(rParagraph.Text, iCaretMove)
End If
ExtractHyperlinks = "<p>" & s & "</p>"
End Function
Function RangeContains(rParent As Range, rChild As Range) As Boolean
If rChild.Start >= rParent.Start And rChild.End <= rParent.End Then
RangeContains = True
Else
RangeContains = False
End If
End Function
I have a macro which takes one Word document, copies the data inside my parameters then pastes it multiple separate documents (in this case three).
This is the first time using VBA, so please go easy.
The original document is a long document, which has multiple repeating sections. By filling in the original document, the user can save time completing one rather than three near identical documents. I have split the original into three sections. My code takes the data from the first declared section and pastes it into a new document. It also works for the third. The second, however does not work.
The
With R.Find
.Text = "START OF FORM*^12"
.MatchWildcards = True
section looks for the text 'Start of Form' and takes that and the rest of the contents up until '^12' (which I believe refers to a page break).
The document is set out so that each section of the document starts with that text and finishes with page break.
Sub DocSplit()
' Declares variable (in this case R).
Dim R As Range
' Sets R to the active document, being a number of ranges (will be defined later).
Set R = ActiveDocument.Range.Duplicate
' You won't be able to see what the macro is doing, but will run quicker.
Application.ScreenUpdating = False
' For R, find text with whatever is in the " marks.
With R.Find
.Text = "START OF FORM*^12"
.MatchWildcards = True
' Runs a series of statements as long as given conditions are true. While it's doing this,
While .Execute
' Copy and saves contents of R.
CopyAndSave R
' While ends.
Wend
'With ends.
End With
' Collapses range to the ending point.
R.Collapse wdCollapseEnd
' Returns or sets the ending character position of a range.
R.End = R.Parent.Range.End
CopyAndSave R
End Sub
Static Sub CopyAndSave(R As Range)
' Declares D as document.
Dim D As Document
' Represents the number of words in the collection.
' Long is a datatype for values too large for "integer".
Dim Count As Long
Count = Count + 1
' Copies R from previous Sub to a new document.
R.Copy
Set D = Documents.Add
' Pastes range, preserving original formatting.
D.Range.PasteAndFormat wdFormatOriginalFormatting
D.SaveAs R.Parent.Path & Application.PathSeparator & _
"F00" & Count, wdFormatDocument
D.Close
End Sub
I did expect three documents, F001, F002 and F003 to be created. I get two files, one containing the first section (as intended) and one file containing the last two.
I took a quick look at your code and I found these errors:
If you want the counter to increment each time the function is called, you must declare it in the main function, otherwise it will lose memory each time it's called.
R.Find needs an argument. If you want more details, look at here
R.End needs an argument, here you'll find some hints, depending on what you need to do.
I've updated some parts of your code to help you:
Sub DocSplit()
' Declares variable (in this case R).
Dim R As Range
' Represents the number of words in the collection.
' Long is a datatype for values too large for "integer".
Dim count As Long
count = 0
' Sets R to the active document, being a number of ranges (will be defined later).
Set R = ActiveDocument.Range.Duplicate
' You won't be able to see what the macro is doing, but will run quicker.
Application.ScreenUpdating = False
' For R, find text with whatever is in the " marks.
With R.Find("Text your're searching")
.Text = "START OF FORM*^12"
.MatchWildcards = True
' Runs a series of statements as long as given conditions are true. While it's doing this,
While .Execute
' Copy and saves contents of R.
Call CopyAndSave(R, count)
' While ends.
Wend
'With ends.
End With
' Collapses range to the ending point.
R.Collapse wdCollapseEnd
' Returns or sets the ending character position of a range.
R.End = R.Parent.Range.End
Call CopyAndSave(R)
End Sub
Static Sub CopyAndSave(R As Range, count As Long)
' Declares D as document.
Dim D As Document
count = count + 1
' Copies R from previous Sub to a new document.
R.Copy
Set D = Documents.Add
' Pastes range, preserving original formatting.
D.Range.PasteAndFormat wdFormatOriginalFormatting
D.SaveAs R.Parent.Path & Application.PathSeparator & _
"F00" & count, wdFormatDocument
D.Close
End Sub
If you have any doubts, don't hesitate to ask.
Say that I have the following code to write headings from an array to a word document and to apply defined styles:
With wdDoc
Set wrdRange = .Range(0, 0) ' Set initial Range.
i = 2
Do Until i > 6
' Debug.Print wrdRange.Start, wrdRange.End
wrdRange.text = totalArray(i, colIndex(3)) & Chr(11)
Set wrdRange = .Paragraphs(i - 1).Range
wrdRange.Style = totalArray(i, colIndex(2))
wrdRange.Collapse 0
i = i + 1
Loop
End With
One would expect the following to occur:
The word range moves programmatically as I move through the document.
The word style is updated for the new range (defined by the set statement)
The Range collapses to the end (0 = wdCollapseEnd) and the loop continues until the initial conditions are satisfied.
What I can't seem to fix is the styles being applied to ALL existing paragraphs in the document. The Debug.Print statement should show the range being updated as expected, despite the fact that the style applies to all existing paragraphs.
As you can tell, I've toyed around with this quite a bit, to no avail. Any help would be appreciated in this matter.
Thanks.
In the following line of code:
wrdRange.text = totalArray(i, colIndex(3)) & Chr(11)
Use Chr(13) instead of Chr(11). The latter is simply a line break, not a new paragraph. So applying a style to any part of the Range is actually applying it to all the text your code is generating because it's a single paragraph.
Given that the cursor is within some TextRange tr, I would like a Sub that takes tr as an input argument and selects (or returns) a TextRange that starts at the start of the current line containing tr.startand ends at the next instance of a "." or ":"). Ideally this would work with an arbitrary TextRange or with the current selection (ActiveWindow.Selection.TextRange). NOTE: it maybe be that tr.Length = 0 (nothing actually selected).
I've answered the question by implementing a loop through all paragraphs in the text frame to find the paragraph containing the cursor, then through the lines in that paragraph to find the line containing the cursor. Then selecting text in the line starting at the first character and extending until the first of a ".", ":" or the end of the line. Then applying the "style" to the selected text. That code is below (some comments follow the code).
I am still hoping for a more elegant solution that doesn't require searching.
Option Explicit
Sub StyleRunInApply()
' Apply the run-in style to current selection (assumed to be a text range). If
' no characters are selected, apply from the beginning of the current line to
' the first of "." or ":" or the end of the current line.
'
' The "run-in style" is defined to be bold with Accent2 color of the current
' master theme.
Dim iLine As Long
Dim lenth As Long
Dim line As TextRange
Dim pgf As TextRange
Dim tr As TextRange
Dim thme As OfficeTheme
Set tr = ActiveWindow.Selection.TextRange
If tr.Length = 0 Then
' Loop through pgfs in parent text frame to find our line--
' the first pgf that ends at or beyond the cursor.
For Each pgf In tr.Parent.TextRange.Paragraphs
If pgf.Start + pgf.Length > tr.Start Or _
pgf.Start + pgf.Length > tr.Parent.TextRange.Length Then GoTo L_foundPgf
Next pgf ' (If fall through, pgf will be the final pgf in the frame.)
L_foundPgf:
' Find last line in pgf that starts before the cursor.
While iLine < pgf.Lines.Count And pgf.Lines(iLine + 1).Start < tr.Start
iLine = iLine + 1
Wend
Set line = pgf.Lines(iLine)
' Now look in the line for a ":" or "." and reset tr from the start of
' the line up to and including the first of a ":" or "." or the end of
' line.
lenth = line.Length
If Not line.Find(":") Is Nothing Then
lenth = line.Find(":").Start - line.Start + 1
ElseIf Not line.Find(".") Is Nothing Then
If line.Find(".").Start - line.Start + 1 < lenth Then
lenth = line.Find(".").Start - line.Start + 1
End If
End If
Set tr = line.Characters(1, lenth)
End If
' Set the finally selected text to the style!
Set thme = ActivePresentation.SlideMaster.Theme
tr.Font.Color = thme.ThemeColorScheme(msoThemeAccent2)
tr.Font.Bold = True
End Sub 'StyleRunInApply
Three comments on the code:
Improvements welcome.
A variation that set the end position of the text to be selected rather than the length seems to be about the same in terms of comprehensibility, size, and elegance.
In defense of the GoTo: I use it only as part of a substitute for "missing" language features, in this case, an Exit For, and then, for such exits, only immediately following the Then, which is the reason for not having a block follow the Then.