i have a document that i'm reviewing with yellow highlighted text. i want a macro to go through and remove the lines that are highlighted. so far this is what i have:
Sub hilight()
'
' hilight Macro
' removes lines in yellow hi-lighter
Dim p As Paragraph
For Each p In ActiveDocument.Paragraphs
Dim holder As String
If p.Range.Text = highlighted_text Then
p.Range.Text = holder
End If
Next p
End Sub
i need to know how highlighted text property is given so i can replace highlighted_text
Here is a solution. Note that it only replaces paragraphs in which the entire paragraph is yellow highlighted, not just part of it. There are a few things worth pointing out:
Replacing a paragraph will also take out the trailing line break, so I include it in the placeholder text
Since a line break is being added, if you don't loop through the paragraphs backwards, it'll be an infinite loop (thus the step -1)
Dim all variables outside of a loop
Sub ReplaceYellowParagrahps()
Dim p As Paragraph
Dim i As Long, count As Long
Dim placeholderText As String
placeholderText = "holder" & vblf
count = ActiveDocument.Paragraphs.count
For i = count To 1 Step -1
With ActiveDocument.Paragraphs(i).Range
If .HighlightColorIndex = wdYellow Then
.Text = placeholderText
End If
End With
Next
End Sub
Related
In My Word Template I have few bullet points, and I will select the required points based on selection from the GUI and remove the rest of the points that are not selected from the code. So it depends on the user how many points that he would select.
I am Tall (bookmark1)
I am Dark (bookmark2)
I am 6.2 feet height (bookmark3)
I Have BMW (bookmark4)
I know 5 different languages (bookmark5)
I have created bookmarks for all these points as shown in the braces above.
Now the problem is, the user selects few number of bullet points from the above list and output would leave an extra blank line below.
I have tried many approaches from changing the selection of the bookmarks to adding bullet point form the code. I need to get rid of the extra blank line.
But nothing seems to work. I would appreciate the help in this. TIA
If .cboChanges1.Value = "No" Then
DeleteBookmark ("bookmark1")
Else
AddBullet ("bookmark1")
End If
If .cboChanges2.Value = "No" Then
DeleteBookmark ("bookmark2")
Else
AddBullet("bookmark2")
End If
etc.. where cboChanges1 and cboChanges2 are combo boxes to choose Yes/no.
Sub DeleteBookmark(strBookmark As String)
Dim rng As Range
Set rng = ActiveDocument.Bookmarks(strBookmark).Range
rng.Delete
Set rng = Nothing
End Sub
Before Screenshot
Output screen after first 3 options, you can see extra blank line as highlighted
I am adding the bullet point dynamically, as follows
Sub AddBullet(strBookmark As String)
ActiveDocument.Bookmarks(strBookmark).Select
Selection.Range.ListFormat.ApplyBulletDefault
End Sub
This is how the bookmarks are arranged,
A table cell always contains an end of cell marker which is a combination of paragraph and end of cell mark. This means that an empty cell always contains at least one paragraph.
As the end of cell marker cannot be deleted when you delete the text in the last bookmark you will get an empty paragraph because the previous bookmarked range ends with a paragraph mark.
You can deal with this in your DeleteBookmark routine by checking the length of the final paragraph of the cell. If it only contains two characters then it has no text and the preceding paragraph mark can be deleted.
Sub DeleteBookmark(strBookmark As String)
Dim rng As Range
Set rng = ActiveDocument.Bookmarks(strBookmark).Range
rng.Delete
Set rng = rng.Cells(1).Range.Paragraphs.Last.Range
If Len(rng.Text) = 2 Then
'paragraph contains no text so delete preceding paragraph mark
rng.Collapse wdCollapseStart
rng.MoveStart wdCharacter, -1
rng.Delete
End If
Set rng = Nothing
End Sub
If you are going to write code for Word you need to learn what the formatting marks are so that you can understand how a document is constructed.
FYI It is not necessary to select a range to apply bullets.
Sub AddBullet(strBookmark As String)
ActiveDocument.Bookmarks(strBookmark).Range.ListFormat.ApplyBulletDefault
End Sub
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.
I have a 400+ page coding manual I use, and unfortunately turned off the green for all the comments in the manual. I can't undo it, as I hadn't noticed it until it was too late. Its ruined years of work.
How would I write VBA to parse the document finding sentences starting with // and ending in a Paragraph mark and change the color of them? Or assign a style to them?
Here is a start that I have cobbled together, I admire people who can write code without intellisence, its like trying to find your way blindfolded
Dim oPara As Word.Paragraph
Dim rng As Range
Dim text As String
For Each oPara In ActiveDocument.Paragraphs
If Len(oPara.Range.text) > 1 Then
Set rng = ActiveDocument.Range(oPara.Range.Start,oPara.Range.End)
With rng.Font
.Font.Color = wdColorBlue
End With
End If
Next
End Sub
The following seems to work:
Dim oPara As Word.Paragraph
Dim text As String
For Each oPara In ActiveDocument.Paragraphs
text = oPara.Range.text
'Check the left 2 characters for //
If Left(oPara.Range.text, 2) = "//" Then
oPara.Range.text = "'" & text
End If
Next
I assume you are using VBA so by placing a ' in front of // it will turn the line green. You could modify the code to replace // with ' if desired. The opera.range.text should grab the entire paragraph.
Edit:
Spaces and tabs everywhere
Goal:
If there's 1 tab or less, check the next paragraph.
If there's 2 or more tabs, leave the first and delete the rest in that paragraph. Check next paragraph.
I want to leave the first paragraph marker so I can turn it into a table with the word in the first column, and the description/definition in the second column.
Attempted Method:
Look at each character in a paragraph and count the tabs. After counting tab characters, if there are more than the desired amount (currently one tab) then replace the first tab in the paragraph with a "^t" (tab character) and then any remaining tabs in that paragraph with "" (nothing, essentially deleting it).
Issues:
The script only sometimes works. It seems to get hung up when there are lines with less than 2 tabs per line.
The other times it'll delete the first tab in a line. The first occurrence should stay while the remainder leave.
The last line of my test word document sometimes isn't touched.
IF I run in repeatedly, it'll delete all tabs in the document except the last one in the last line.
Description:
I am an ugly coder, sorry. I'm self taught with loops, if/thens, and recording and modifying macros. This is not homework, it's so I don't have to manually go through 1,500 documents to format them since people use tabs to align text instead of the ruler bar. Pacman mode (show/hide non-printable characters mode) is very scary looking.
Sub TabFinder()
Dim oPara As Word.Paragraph 'paragraph
Dim var 'a counter for a FOR loop for finding tabs in a paragraph, represents a single character
Dim TabCounter As Long 'how many tabs will be in a paragraph
Dim oChar As Word.Characters 'characters in a paragraph
Dim StartHere As Long 'not currently used - thought I would try and save the location of the first tab to save it
Dim TabsFoundAndReplaced As Long 'how many times the program has replaced a tab in a line
Dim ReplaceText 'first tab will replace with a tab, 2nd and greater tab will be replaced with nothing
Dim ReplaceAmmount As Long 'counter for how many times tabs have been replaced per line
Dim TabsWantedPerLine As Long 'number of tabs we should keep in a line and not replace
TabsWantedPerLine = 1 'desired upper limit of tabs to stay in a line
Selection.HomeKey Unit:=wdStory 'go to the beginning of the document first for find feature
For Each oPara In ActiveDocument.Paragraphs 'for every paragraph in the document
TabCounter = 0
Set oChar = oPara.Range.Characters 'find the number of characters, and set oChar as the total
For var = 1 To oChar.Count 'for each character do the following
If oChar(var) <> "" Then 'stops an error
Select Case Asc(oChar(var)) 'stops an error
Case 9 '9 is tabs 'if there character oChar is a tab, then do the following
'If TabCounter = 0 Then StartHere = var 'not used currently, just a thought on how to save the tab with additional coding
TabCounter = TabCounter + 1 'counts tabs in the line
End Select
End If
Next
If TabCounter > TabsWantedPerLine Then 'if there are more tabs in a paragraph than upper limit, do the following (hopefully deleting any after the desired tabs
For ReplaceAmmount = 1 To TabCounter 'do this for each of the tabs in the paragraph
If ReplaceAmmount <= TabsWantedPerLine Then ReplaceText = "^t" Else ReplaceText = "" 'replaces the
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^t"
.Replacement.Text = ReplaceText 'replaces with a "^t" if first go around or "" if >1st go around
.Forward = True
.Wrap = wdFindStop
End With
With Selection
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseStart
Else
.Collapse Direction:=wdCollapseEnd
End If
.Find.Execute replace:=wdReplaceOne
'.Find.Execute
Set oChar = oPara.Range.Characters 'since we have replaced some characters in the paragraph
End With
Next ReplaceAmmount
End If
Next 'for each oPara
End Sub
This code makes permanent changes to your data, so test it before using in real life.
This code seems to do what you want.
Sub TabFinder()
Dim i As Long
Const sFAKETAB As String = "|tab|"
For i = 1 To ThisDocument.Paragraphs.Count
'replace the first tab w a fake one
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, vbTab, sFAKETAB, 1, 1)
'replace all other tabs w nothing
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, vbTab, vbNullString)
'replace the fake tab w a real tab
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, sFAKETAB, vbTab)
Next i
End Sub
Here's the thing about using a For Each and changing the .Range.Text property: it doesn't work. It seems to reset which paragraph it's on. Kind of like when you delete something in a For Each loop and VBA loses track of where it is. So the above line are a little more verbose than 1) using For Each 2) using a With Block and/or 3) setting an object variable, but it works.
Update
Or you can replace the tabs with spaces, per Wayne's excellent comment.
Sub TabFinder3()
Dim i As Long
Dim j As Long
Const sFAKETAB As String = "|tab|"
Const lMAXTABS As Long = 5 'the maximum adjacent tabs you would have
For i = 1 To ThisDocument.Paragraphs.Count
'replace the first tab a fake one
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, vbTab, sFAKETAB, 1, 1)
'replace all other tabs w a space - multiple tabs replace wWith one space
For j = lMAXTABS To 1 Step -1
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, String(j, vbTab), Space(1))
Next j
'replace the fake tab w a real tab
ThisDocument.Paragraphs(i).Range.Text = Replace(ThisDocument.Paragraphs(i).Range.Text, sFAKETAB, vbTab)
Next i
End Sub
Let's try something like this which just uses some simple string functions.
First, iterate the paragraphs by index position (I couldn't make it work with a For Each oPara loop).
Capture each paragraph's text in a string variable: paraText
Use a Do ... Loop construct to replace the tabs with the string Replace function. The replacement text is assigned dynamically using the IIF function, which will use "^t" if TabCounter=1 or otherwise use the null string "". This loops until there are no tab characters in the string.
Once the paraText string has been thoroughly manipulated, simply assign that string to the oPara.Range.Text = paraText:
Option Explicit
Sub TabFinder()
Dim oPara As Word.Paragraph 'paragraph
Dim var 'a counter for a FOR loop for finding tabs in a paragraph, represents a single character
Dim TabCounter As Long 'how many tabs will be in a paragraph
Dim TabsWantedPerLine As Long 'number of tabs we should keep in a line and not replace
Dim paraText As String 'represents the string of each paragraph
TabsWantedPerLine = 1 'desired upper limit of tabs to stay in a line
Selection.HomeKey Unit:=wdStory 'go to the beginning of the document first for find feature
For var = 1 To ActiveDocument.Paragraphs.Count 'for every paragraph in the document
Set oPara = ActiveDocument.Paragraphs(var)
TabCounter = 0
paraText = oPara.Range.Text
'# Loop until there are no more tabs left to replace
Do Until InStr(paraText, Chr(9)) = 0
TabCounter = TabCounter + 1
'# replace tabs in our temporary string variable:
paraText = Replace(paraText, Chr(9), IIf(TabCounter = 1, "^t", vbNullString), , 1)
Loop
'# Assign our new string ot the paragraph range
oPara.Range.Text = paraText
Next var
End Sub
Updated from comments above
Backwards iteration over each character in paragraph, delete character IF it's a tab AND there is another tab somwhere to the left of it within the paragraph. This is functionally same as ensuring there is only one tab per paragraph, and only the first one should remain.
Example document:
Example output:
Here is the updated code. This would need more (probably a lot more) tweaking if you wanted to allow more than one tab per paragraph, but since the limit is 1, I think this works.
Note: This does not address indentation which Word recognizes distinctly from the paragraph's text.
Sub TabFinder()
Dim oPara As Word.Paragraph 'paragraph
Dim var 'a counter for a FOR loop for finding tabs in a paragraph, represents a single character
Dim i As Integer
Dim paraText As String 'represents the string of each paragraph
Selection.HomeKey Unit:=wdStory 'go to the beginning of the document first for find feature
LeaveFirstTab = False
For var = 1 To ActiveDocument.Paragraphs.Count 'for every paragraph in the document
Set oPara = ActiveDocument.Paragraphs(var)
For i = oPara.Range.Characters.Count To 1 Step -1
If Mid(oPara.Range.Text, i, 1) = Chr(9) Then
'As long as there's another tab to the left of this one, delete this one
If InStr(Left(oPara.Range.Text, i - 1), Chr(9)) > 1 Then
oPara.Range.Characters(i).Delete
End If
End If
Next
Next
End Sub
Updated to explain Mid() Function
The VBA Mid function takes a substring of specified length, starting at a specified position, from a string. Syntax is:
MID( string, start_position, number_of_characters )
So in the code above, we are taking the substring beggining at i (our character iterator) with a length of 1. This is basic way to iterate over characters in a string.
I just noticed though that there is a better/simpler way to do this with Word's object model. Instead of the Mid function, I think you can use oPara.Range.Characters(i) to return the same substring. I don't know why I didn't realize this earlier because we actually use that method two lines later when we do the .Delete!
So modified:
For i = oPara.Range.Characters.Count To 1 Step -1
If oPara.Range.Characters(i) = Chr(9) Then
'As long as there's another tab to the left of this one, delete this one
If InStr(Left(oPara.Range.Text, i - 1), Chr(9)) > 1 Then
oPara.Range.Characters(i).Delete
End If
End If
Next
I'm writing a VB Macro to do some processing of documents for my work.
The lines of text are searched and the bracketed text is put in a list(box).
The problem comes when I want to remove all hyperlinks in the document and then generate new ones (not necessarily in the location of the original hyperlinks)
So the problem is How do I remove the existing hyperlinks?
My current issue is that every time a link gets added, the hyperlinks count goes up one, but when you delete it, the count does NOT reduce. (as a result I now have a document with 32 links - all empty except for 3 I put in myself - they do not show up in the document)
At the end of the code are my attempts at removing the hyperlinks.
Private Sub FindLinksV3_Click()
ListOfLinks.Clear
ListOfLinks.AddItem Now
ListOfLinks.AddItem ("Test String 1")
ListOfLinks.AddItem ActiveDocument.FullName
SentenceCount = ActiveDocument.Sentences.Count
ListOfLinks.AddItem ("Sentence Count:" & SentenceCount)
counter = 0
For Each myobject In ActiveDocument.Sentences ' Iterate through each element.
ListOfLinks.AddItem myobject
counter = counter + 1
BracketStart = (InStr(1, myobject, "("))
If BracketStart > 0 Then
BracketStop = (InStr(1, myobject, ")"))
If BracketStop > 0 Then
ListOfLinks.AddItem Mid$(myobject, BracketStart + 1, BracketStop - BracketStart - 1)
ActiveDocument.Sentences(counter).Select
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"http://testnolink/" & counter, ScreenTip:="" 'TextToDisplay:=""
End If
End If
Next
'ActiveDocument.Sentences(1).Select
'
'Selection.Range.Hyperlinks(1).Delete
ActiveDocument.Hyperlinks.Item(1).Delete
Debug.Print ActiveDocument.Hyperlinks.Count
End Sub
This is an old post, so am adding this VBA code in case it is useful to someone.
Hyperlinks (Collections) need to be deleted in reverse order:
Sub RemoveHyperlinksInDoc()
' You need to delete collection members starting from the end going backwards
With ActiveDocument
For i = .Hyperlinks.Count To 1 Step -1
.Hyperlinks(i).Delete
Next
End With
End Sub
Sub RemoveHyperlinksInRange()
' You need to delete collection members starting from the end going backwards
With Selection.Range
For i = .Hyperlinks.Count To 1 Step -1
.Hyperlinks(i).Delete
Next
End With
End Sub
The line removing the hyperlink is commented out. The following line will remove the first hyperlink within the selected range:
Selection.Range.Hyperlinks(1).Delete
This will also decrement Selection.Range.Hyperlinks.Count by 1.
To see how the count of links is changing you can run the following method on a document:
Sub AddAndRemoveHyperlink()
Dim oRange As Range
Set oRange = ActiveDocument.Range
oRange.Collapse wdCollapseStart
oRange.MoveEnd wdCharacter
Debug.Print ActiveDocument.Range.Hyperlinks.Count
ActiveDocument.Hyperlinks.Add oRange, "http://www.example.com"
Debug.Print ActiveDocument.Range.Hyperlinks.Count
ActiveDocument.Hyperlinks.Item(1).Delete
Debug.Print ActiveDocument.Range.Hyperlinks.Count
End Sub