I'm writing a Microsoft Word VBA macro that runs through every paragraph of a word document and adds a comment to every paragraph. That comment contains the style for that paragraph. This way a coworker can print out the document with comments and know how to style similar documents in the future.
I'm almost there, the code adds the comments to every paragraph, but dies at the first row of a table:
"This method or property is not available because the object refers to the end of a table row."
Here is the code:
Sub aa_AddStylesComment()
'
' aa_AddStylesComment Macro
' Author: Me!
'
Dim strParaStyle As String
Dim cmtNewComment As Comment
'Run through word file and delete any comments with author set to a space character (that is the author of the comments added by the script)
For J = ActiveDocument.Comments.Count To 1 Step -1
With ActiveDocument
If .Comments(J).Author = " " Then
.Comments(J).Delete
End If
End With
Next J
'Running through every paragraph
For i = 1 To ActiveDocument.Paragraphs.Count
With ActiveDocument
'Get paragraph style
strParaStyle = .Paragraphs(i).Style
'Create a new comment and collect it - then change the author to space character
Set cmtNewComment = Selection.Comments.Add(.Range(.Paragraphs(i).Range.Words(1).Start, (.Paragraphs(i).Range.Words(1).End - 1)), strParaStyle)
cmtNewComment.Author = " "
End With
Next
End Sub
You can add a check if it is a table, and then if the paragraph has cells, as follows:
If .Paragraphs(i).Range.Tables.Count = 0 Then
Set cmtNewComment = .Paragraphs(i).Range.Comments.Add(.Range(.Paragraphs(i).Range.Words(1).Start, (.Paragraphs(i).Range.Words(1).End - 1)), strParaStyle)
cmtNewComment.Author = " "
ElseIf .Paragraphs(i).Range.Cells.Count > 0 Then
Set cmtNewComment = .Paragraphs(i).Range.Comments.Add(.Range(.Paragraphs(i).Range.Words(1).Start, (.Paragraphs(i).Range.Words(1).End - 1)), strParaStyle)
cmtNewComment.Author = " "
End If
Note that you don't need to use the Selection as you never change it.
Related
In analogy to this question, I would like to script a VBA script that counts words formatted with a certain document style, more precisely: a certain paragraph style.
Sub CountTypeface()
Dim lngWord As Long
Dim lngCountIt As Long
Const Typeface As String = "Calibri"
Const MyFormat As String = "My Paragraph Style"
'Ignore any document "Words" that aren't real words (CR, LF etc)
For lngWord = 1 To ActiveDocument.Words.Count
If Len(Trim(ActiveDocument.Words(lngWord))) > 1 Then
If ActiveDocument.Styles(lngWord) = MyFormat Then
lngCountIt = lngCountIt + 1
End If
End If
Next lngWord
MsgBox "Number of " & Typeface & " words: " & lngCountIt
End Sub
But running this code results in the runtime error:
runtime error "5941".: the requested member of the collection does not exist
Why does this happen and how to fix it?
You're using your word count iterator as the index for the style collection. You have more words than Styles has indices, and the If would only be true one time, since you aren't checking the word's style.
Replace:
If ActiveDocument.Styles(lngWord) = MyFormat Then
With:
If ActiveDocument.Words(lngWord).Style = MyFormat Then
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.
This is probably simple but I can't get it to work.
I need to search through my document, find words that contain the string 'alog' and add 'ue'. For example, 'catalogs' --> 'catalogues'.
The above works fine but I can't get the next bit to work: if a found string already has 'ue' after the 'log' I don't want to add another 'ue'.
The subroutine accessed from the macro is below. I've tried adding the following lines into the 'while execute' part, but 'selection' always turns out to be the word where the cursor happens to be.
With Selection
.Expand unit:=wdWord
End With
How do I i) select the content of the found range and ii) expand that new selection by two characters to see if those two characters are 'ue' ?
Many thanks.
Sub do_replace2(old_text As String, new_text As String, Count_changes As Integer)
' Replaces 'log' with 'logue'
' Ignores paragraphs in styles beginning with 'Question'
Dim rg As Range
Set rg = ActiveDocument.Range
With rg.Find
.Text = old_text
While .Execute
If Left(rg.Paragraphs(1).Style, 8) <> "Question" Then
rg.Text = new_text
With ActiveDocument.Comments.Add(rg, "Changed from '" & old_text & "'")
.Initial = "-logs"
.Author = "-logs"
End With
Count_changes = Count_changes + 1
End If
rg.Collapse wdCollapseEnd
Wend
End With
End Sub
I'm not quite sure I follow the first part of your question "How do I select the content of the found range". The rg variable already contains the search result. If you want to select it, just use rg.Select. This might be useful in debugging (so you can see where the Range is when you're stepping through the code), but there isn't really any other reason to use the Selection object in the code from your question. You can just use the Range object instead.
As to part 2 of your question "How do I ... expand that new selection by two characters", all you need to do is add 2 to the .End property of the Range. Since you're only using this for a test (and because the .Find method can be dodgy), test this on a copy of rg:
With rg.Find
.Text = old_text
While .Execute
If Left(rg.Paragraphs(1).Style, 8) <> "Question" Then
Dim test As Range
Set test = rg.Duplicate 'copy the found Range.
test.Collapse wdCollapseEnd 'move to the end of it.
test.End = test.End + 2 'expand to the next 2 characters.
If test.Text <> "ue" Then 'see if it's "ue".
rg.Text = new_text
With ActiveDocument.Comments.Add(rg, "Changed from '" & old_text & "'")
.Initial = "-logs"
.Author = "-logs"
End With
Count_changes = Count_changes + 1
End If
End If
rg.Collapse wdCollapseEnd
Wend
End With
Good Day all. I'm far from a programmer however i need assistance finding out the error with this VBA script. It is run in a word document for repair order form. Its purpose is to increase the order number by one for each print. The counter updates a .txt file To identify the next number needed to print. That as far as my understanding goes. The code is below.
Sub serialNumberPrint()
'
' SerialNumber Macro
'
'
Dim Message As String, Title As String, Default As String, NumCopies As Long
Dim Rng1 As Range
' Set prompt.
Message = "Enter the number of copies that you want to print"
' Set title.
Title = "Print"
' Set default.
Default = "1"
' Display message, title, and default value.
NumCopies = Val(InputBox(Message, Title, Default))
SerialNumber = System.PrivateProfileString("C:\Users\GaleR\Documents\SettingsSerial.Txt", _
"MacroSettings", "SerialNumber")
If SerialNumber = "" Then
SerialNumber = 1
End If
Set Rng1 = ActiveDocument.Bookmarks("SerialNumber").Range
Counter = 0
While Counter < NumCopies
Rng1.Delete
Rng1.Text = Format(SerialNumber, "000#")
ActiveDocument.PrintOut
SerialNumber = SerialNumber + 1
Counter = Counter + 1
Wend
'Save the next number back to the Settings.txt file ready for the next use.
System.PrivateProfileString("C:\Users\GaleR\Documents\SettingsSerial.txt", "MacroSettings", _
"SerialNumber") = SerialNumber
'Recreate the bookmark ready for the next use.
With ActiveDocument.Bookmarks
.Add Name:="SerialNumber", Range:=Rng1
End With
ActiveDocument.Save
End Sub
The debug brings me to this line:
Set Rng1 = ActiveDocument.Bookmarks("SerialNumber").Range
I am at wits end and am not sure how to proceed. I apologize beforehand for my lack of knowledge but really do need the assistance.
The error is telling you that the bookmark SerialNumber does not exist in the document. If you select the place in the document (or template) and insert a bookmark with that name it should solve the problem.
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