Context: Microsoft Word programming via VBA or VSTO.
The Comments property of a Word Document object allows enumerating over all comments in a Word document.
How can you find the current heading for a Word comment?
Example document:
Heading 1
Heading 1.1
(commment A)
Output:
comment A - Heading 1.1
I couldn't find easier way of doing it but it's working. The following code is searching for last heading before first comment in active document. You can easily adopt it for all comments using For Each loop.
Sub Heading_Above_Comment()
Dim COMM As Comment
Set COMM = ActiveDocument.Comments(1)
'set new selection for range to search
Dim rngWHERE As Range
Set rngWHERE = ActiveDocument.Range(0, COMM.Reference.Start)
rngWHERE.Select
Selection.Find.ClearFormatting
'set heading style name you applied>>
Selection.Find.Style = ActiveDocument.Styles("Nagłówek 1")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindContinue
.Format = True
End With
Do While Selection.Find.Execute
If Selection.End < COMM.Reference.Start And _
Selection.Start > rngWHERE.Start Then
Set rngWHERE = Selection.Range
Else
Exit Do
End If
Loop
'select the range
rngWHERE.Select
'range selected is last heading
MsgBox "last heading befor comment is selected and it is: " & Selection.Text
End Sub
How it works:
Reference.GoTo will take you to the current heading (if there is one).
(See also: Text of the preceding heading in word)
Dim COMM As Comment
Set COMM = ActiveDocument.Comments(1)
Dim heading As Range
Set heading = COMM.Reference.GoTo(What:=wdGoToHeading, Which:=wdGoToPrevious)
' Get heading numbering string
Dim hNum$
hNum$ = heading.ListFormat.ListString
' Get heading text
Dim hText$
' Expand the range to the whole paragraph (final CR included)
heading.Expand Unit:=wdSentence
hText$ = heading.Text
MsgBox hNum$ & vbTab & """" & Left(hText$, Len(hText$) - 1) & """"
Now if you want the whole level:
Dim headingLevel As Range
' headingLevel encompasses the region under the heading preceding COMM
Set headingLevel = COMM.Reference.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Related
I am doing a wildcard search loop in MS Word and generating the list of all the find values in a new document using following code. I have added page numbers to the output. But I can't think of how to get the headers for the searched output. Pls suggest.
Sample Word Document:
1 Heading
Text Text Text Text Text
--<Page Break>--
1.1 Heading
Text Text Text Text Text [Reference X1]
1.1.1 Heading
Text Text Text Text Text
Text Text Text Text Text
Text Text Text Text Text
--<Page Break>--
1.2 Heading
Text Text Text Text Text
1.2.1 Heading
Text Text Text Text Text
Text Text Text Text Text [Reference X2]
Text Text Text Text Text [Reference X3]
The 1, 1.1, etc headings are the default heading styles used in MS word. (For me the style name is "Heading 1", "Heading 2", etc.)
The output I am expecting is as under in a tabular format:
| Reference | Heading | Page |
| Reference X1 | 1.1 Heading | 2 |
| Reference X2 | 1.2.1 Heading | 3 |
| Reference X2 | 1.2.1 Heading | 3 |
The Code (part of the sub that does this finding and writing in the table) I have been able to write so far is:
With oDoc
Set oRange = .Range
n = 1
With oRange.Find
.Text = "<Reference X[0-9]{1,}>"
.Forward = True
.MatchWildcards = True
Do While .Execute
strFound = oRange
With oTable
.Cell(n+1,1).Range.Text = strFound
.Cell(n+1,3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
Loop
End With
End With
I already have the code for defining these variables, creating a table and required rows in it. I am only confused about how to get the heading just above the found item. The issue is there can be one or multiple "Reference XX" under one heading. Further, the heading level can be any. And I need separate rows for each item found using the wildcard.
For example:
Sub GetRefHeadings()
Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String, Tbl As Table
StrOut = "Ref." & vbTab & "Heading" & vbTab & "Page" & vbCr
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<Reference X[0-9]#>"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
StrOut = StrOut & .Text & vbTab & Rng.Paragraphs.First.Range.ListFormat.ListString & _
" " & Split(Rng.Text, vbCr)(0) & vbTab & Rng.Information(wdActiveEndPageNumber) & vbCr
Loop
End With
Set Rng = ActiveDocument.Range.Characters.Last
Rng.Text = StrOut
Set Tbl = Rng.ConvertToTable(Separator:=vbTab)
With Tbl
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
.Rows(1).Range.Font.Bold = True
.Rows(1).HeadingFormat = True
'.Sort ExcludeHeader:=True, FieldNumber:=1
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
If you want the found text's page # instead of the heading's page #, change Rng.Information to .Information.
The default sort order is by reference found, regardless of the Reference #, which coincides with sorting by Heading. The code also includes a commented-out line to sort by Reference # instead.
You can find the heading level of the section of text you've found using a predefined bookmark. Since this trick uses the Selection object, you have to transfer the "found text" range to Selection. This code snippet below shows how:
Option Explicit
Sub test()
With ActiveDocument
Dim foundThis As Range
Set foundThis = .Range
With foundThis.Find
.Text = "<Reference X[0-9]{1,}>"
.Forward = True
.MatchWildcards = True
Do While .Execute
Dim strFound As String
Dim heading As String
strFound = foundThis.Text
heading = foundThis.GoTo(What:=wdGoToBookmark, _
Name:="\HeadingLevel").Paragraphs(1).Range.Text
Debug.Print "string found: " & strFound & " on page " & _
foundThis.Information(wdActiveEndPageNumber) & _
", Heading: " & heading
Loop
End With
End With
End Sub
I have a Word macro that allows to put his/her cursor anywhere in a Word document and it finds and saves the Heading 1, Heading 2 and Heading 3 text that is above the text selected by the user in order capture the chapter, section and sub-section that is associated with any sentence in the document.
I am currently using the code below which moves up the document line-by-line until it finds a style that contains "Heading x". When I have completed this task I move down the number of lines that I moved up to get to Heading 1, which may be many pages.
As you can imagine this is awkward, takes a long time (sometimes 60+ seconds) and is visually disturbing.
The code below is that subroutine that identifies the heading.
Dim str_heading_txt, hdgn_STYLE As String
Dim SELECTION_PG_NO as Integer
hdng_STYLE = Selection.Style
Do Until Left(hdng_STYLE, 7) = "Heading"
LINESUP = LINESUP + 1
Selection.MoveUp Unit:=wdLine, COUNT:=1
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
hdng_STYLE = Selection.Style
'reached first page without finding heading
SELECTION_PG_NO = Selection.Information(wdActiveEndPageNumber)
If SELECTION_PG_NO = 1 Then 'exit if on first page
a_stop = True
Exit Sub
End If
Loop
str_heading_txt = Selection.Sentences(1)
I tried another approach below in order to eliminate the scrolling and performance issues using the Range.Find command below.
I am having trouble getting the selection range to move to the text with the "Heading 1" style. The code selects the sentence at the initial selection, not the text with the "Heading 1" style.
Ideally the Find command would take me to any style that contained "Heading" but, if required, I can code separately for "Heading 1", "Heading 2" and "Heading 3".
What changes to the code are required so that "Heading 1" is selected or, alternatively, that "Heading" is selected?
Dim str_heading_txt, hdgn_STYLE As String
Dim Rng As Range
Dim Fnd As Boolean
Set Rng = Selection.Range
With Rng.Find
.ClearFormatting
.Style = "Heading 1"
.Forward = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
hdng_STYLE = Selection.Style
str_heading_txt = Selection.Sentences(1)
End With
End If
Any assistance is sincerely appreciated.
You can use the range.GoTo() method.
Dim rngHead As Range, str_heading_txt As String, hdgn_STYLE As String
Set rngHead = Selection.GoTo(wdGoToHeading, wdGoToPrevious)
'Grab the entire text - headers are considered a paragraph
rngHead.Expand wdParagraph
' Read the text of your heading
str_heading_txt = rngHead.Text
' Read the style (name) of your heading
hdgn_STYLE = rngHead.Style
I noticed that you used Selection.Sentences(1) to grab the text, but headings are already essentially a paragraph by itself - so you can just use the range.Expand() method and expand using wdParagraph
Also, a bit of advice:
When declaring variables such as:
Dim str_heading_txt, hdgn_STYLE As String
Your intent was good, but str_heading_txt was actually declared as type Variant. Unfortunately with VBA, if you want your variables to have a specific data type, you much declare so individually:
Dim str_heading_txt As String, hdgn_STYLE As String
Or some data types even have "Shorthand" methods known as Type Characters:
Dim str_heading_txt$, hdgn_STYLE$
Notice how the $ was appended to the end of your variable? This just declared it as a String without requiring the As String.
Some Common Type-Characters:
$ String
& Long
% Integer
! Single
# Double
You can even append these to the actual value:
Dim a
a = 5
Debug.Print TypeName(a) 'Prints Integer (default)
a = 5!
Debug.Print TypeName(a) 'Prints Single
Try something based on:
Sub Demo()
Dim Rng As Range, StrHd As String, s As Long
s = 10
With Selection
Set Rng = .Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
StrHd = Rng.Paragraphs.First.Range.Text
Do While Right(Rng.Paragraphs.First.Style, 1) > 1
Rng.End = Rng.Start - 1
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
With Rng.Paragraphs.First
If Right(.Style, 1) < s Then
s = Right(.Style, 1)
StrHd = .Range.Text & StrHd
End If
End With
Loop
MsgBox StrHd
End With
End Sub
I'm new to VBA and would greatly appreciate some help on a problem.
I have long Word documents where I need to apply standard comments to the same set of keywords, but only in selected sections of the document. The following macro worked to find a keyword and apply a comment (from question here https://superuser.com/questions/547710/macro-to-insert-comment-bubbles-in-microsoft-word):
Sub label_items()
'
' label_items Macro
'
'
Do While Selection.Find.Execute("keyword1") = True
ActiveDocument.Comments.Add range:=Selection.range, Text:="comment for keyword 1"
Loop
End Sub
The two modifications are:
1) only apply the comments to user selected text, not the whole document. I tried a "With Selection.Range.Find" approach but I don't think comments can be added this way (??)
2) repeat this for 20+ keywords in the selected text. The keywords aren't totally standard and have names like P_1HAI10, P_1HAI20, P_2HAI60, P_HFS10, etc.
EDIT: I have tried to combine code from similar questions ( Word VBA: finding a set of words and inserting predefined comments and Word macro, storing the current selection (VBA)) but my current attempt (below) only runs for the first keyword and comment and runs over the entire document, not just the text I have highlighted/selected.
Sub label_items()
'
' label_items Macro
'
Dim selbkup As range
Set selbkup = ActiveDocument.range(Selection.range.Start, Selection.range.End)
Set range = selbkup
Do While range.Find.Execute("keyword 1") = True
ActiveDocument.Comments.Add range, "comment for keyword 1"
Loop
Set range = selbkup
Do While range.Find.Execute("keyword 2") = True
ActiveDocument.Comments.Add range, "comment for keyword 2"
Loop
'I would repeat this process for all of my keywords
End Sub
I've combed through previous questions and the Office Dev Center and am stuck. Any help/guidance is greatly appreciated!
It's a matter of adding a loop and a means of Finding the next keyword you're looking for. There are a few suggestions in the code example below, so please adjust it as necessary to fit your requirements.
Option Explicit
Sub label_items()
Dim myDoc As Document
Dim targetRange As Range
Set myDoc = ActiveDocument
Set targetRange = Selection.Range
'--- drop a bookmark to return the cursor to it's original location
Const RETURN_BM = "OrigCursorLoc"
myDoc.Bookmarks.Add Name:=RETURN_BM, Range:=Selection.Range
'--- if nothing is selected, then search the whole document
If Selection.Start = Selection.End Then
Selection.Start = 0
targetRange.Start = 0
targetRange.End = myDoc.Range.End
End If
'--- build list of keywords to search
Dim keywords() As String
keywords = Split("SMS,HTTP,SMTP", ",", , vbTextCompare)
'--- search for all keywords within the user selected range
Dim i As Long
For i = 0 To UBound(keywords)
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
Do
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Text = keywords(i)
.Execute
If .Found Then
If (Selection.Start < targetRange.End) Then
Selection.Comments.Add Selection.Range, _
Text:="Found the " & keywords(i) & " keyword"
Else
Exit Do
End If
Else
Exit Do
End If
End With
Loop
Next i
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
End Sub
I have VBA code that runs through a document and identifies acronyms using wildcards and places them in a separate word document. Some of my writers don't always follow the proper style guides for acronyms so I'm running four different scripts to find all the possible acronyms. It's time consuming and I end up with multiple documents. Is there a method to run multiple searches from one script and have all the results placed in the separate document. Truth in Advertising: I found this script on the 'net, but I've been playing with it to attempt to make it do some other features. Adding current script:
Sub ExtractVariousValuesACRONYMSToNewDocument()
'The macro creates a new document,
'finds all words consisting of 2 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 2 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 2 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{2" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
The best solution would be one searching pattern for all cases. Word hasn't full regular expressions, it is not always possible. Write all four patterns, maybe there is a way for join them into one super-pattern.
The second possibility is running multiple times the same algorithm in one macro, something like this:
Sub Example()
Dim patterns As String
Dim pts() As String
'list of patterns for each run delimited by a delimiter - comma in this example
patterns = "first pattern, second pattern, and so on"
pts = Split(patterns, ",") 'the second parameter is a delimiter
Dim i As Integer
For i = 0 To UBound(pts)
'do your subroutine for each searching pattern
Next i
'save document with result
End Sub
For better answer give us more details, please.
I looked up some examples, but I cannot quite understand how the Range object works. I am trying to loop through each of my headings (of level 4) and have a nested loop that looks through all the tables in between the headings. I cannot figure out how to set that specific range, so any help will be greatly appreciated.
Dim myHeadings As Variant
myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
For iCount = LBound(myHeadings) To UBound(myHeadings)
level = getLevel(CStr(myHeadings(iCount)))
If level = 4 Then
'This is where I want to set a range between myHeadings(iCount) to myHeadings(iCount+1)
set aRange = ??
End If
Next iCount
You are on the right track here. The myHeadings variable you have simply gives a list of the strings of the Level 4 Headings in the document. What you need to do is then search the document for those strings to get the range of the Level 4 Headings.
Once you have the range of each of the headings you can check for the tables in the range between these headings. I've modified your code slightly to do this. Also note its good practice to put Option Explicit at the top of your module to ensure all variables are declared.
My code will tell you how many tables are between each of the Level 4 headings. NOTE: It does not check between the last heading and the end of the document, I'll leave that up to you ;)
Sub DoMyHeadings()
Dim iCount As Integer, iL4Count As Integer, Level As Integer, itabCount As Integer
Dim myHeadings As Variant, tbl As Table
Dim Level4Heading() As Range, rTableRange As Range
myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
'We want to move to the start of the document so we can loop through the headings
Selection.HomeKey Unit:=wdStory
For iCount = LBound(myHeadings) To UBound(myHeadings)
Level = getLevel(CStr(myHeadings(iCount)))
If Level = 4 Then
'We can now search the document to find the ranges of the level 4 headings
With Selection.Find
.ClearFormatting 'Always clear find formatting
.Style = ActiveDocument.Styles("Heading 4") 'Set the heading style
.Text = VBA.Trim$(myHeadings(iCount)) 'This is the heading text (trim to remove spaces)
.Replacement.Text = "" 'We are not replacing the text
.Forward = True 'Move forward so we can each consecutive heading
.Wrap = wdFindContinue 'Continue to the next find
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
'Just make sure the text matches (it should be I have a habit of double checking
If Selection.Text = VBA.Trim$(myHeadings(iCount)) Then
iL4Count = iL4Count + 1 'Keep a counter for the L4 headings for redim
ReDim Preserve Level4Heading(1 To iL4Count) 'Redim the array keeping existing values
Set Level4Heading(iL4Count) = Selection.Range 'Set the range you've just picked up to the array
End If
End If
Next iCount
'Now we want to loop through all the Level4 Heading Ranges
For iCount = LBound(Level4Heading) To UBound(Level4Heading) - 1
'Reset the table counter
itabCount = 0
'Use the start of the current heading and next heading to get the range in between which will contain the tables
Set rTableRange = ActiveDocument.Range(Level4Heading(iCount).Start, Level4Heading(iCount + 1).Start)
'Now you have set the range in the document between the headings you can loop through
For Each tbl In rTableRange.Tables
'This is where you can work your table magic
itabCount = itabCount + 1
Next tbl
'Display the number of tables
MsgBox "You have " & itabCount & " table(s) between heading " & Level4Heading(iCount).Text & " And " & Level4Heading(iCount + 1).Text
Next iCount
End Sub
You could jump from one heading to the next using Goto. See below how to loop through level 4 headings.
Dim heading As Range
Set heading = ActiveDocument.Range(start:=0, End:=0)
Do ' Loop through headings
Dim current As Long
current = heading.start
Set heading = heading.GoTo(What:=wdGoToHeading, Which:=wdGoToNext)
If heading.start = current Then
' We haven't moved because there are no more headings
Exit Do
End If
If heading.Paragraphs(1).OutlineLevel = wdOutlineLevel4 Then
' Now this is a level 4 heading. Let's do something with it.
' heading.Expand Unit:=wdParagraph
' Debug.Print heading.Text
End If
Loop
Don't look specifically for "Heading 4" because,
one may use non built-in styles,
it would not work with international versions of Word.
Check the wdOutlineLevel4 instead.
Now, to get the range for the whole level 4, here is a little known trick:
Dim rTableRange as Range
' rTableRange will encompass the region under the current/preceding heading
Set rTableRange = heading.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
This will work better for the last heading 4 in the document or the last one below a heading 3.