I have a document with comments on a long interview transcript. I found a Macro on SO that let's me export those comments with the highlighted text. This is awesome but the output is terribly dull (plain text).
I need to know if and how to apply bold, italic and insert newlines. I have looked for like an hours now and because my VBA is terrible I have no reference for where to look other than keyword searches on "marco output formatting"
Does someone know how to take the below script and font changes to parts of the text?
Sub ExportComments()
Dim s As String
Dim cmt As Word.Comment
Dim doc As Word.Document
For Each cmt In ActiveDocument.Comments
s = s & "Text: " & cmt.Scope.FormattedText & " -> "
s = s & "Comments: " & cmt.Initial & cmt.Index & ":" & cmt.Range.Text & vbCr
Next
Set doc = Documents.Add
doc.Range.Text = s
End Sub
Maybe I can do it with HTML interpreted by Word?
I'm assuming that the formatting you want included is already within the comment text, and that you are just looking for a way to get that into your final document. Here is a modified version of your script that will do that (with one caveat, listed below):
Sub ExportComments()
Dim cmt As Comment
Dim newdoc As Document
Dim currDoc As Document
Set currDoc = ActiveDocument
Set newdoc = Documents.Add
currDoc.Activate
For Each cmt In currDoc.Comments
With newdoc.Content
cmt.Scope.Copy
.InsertAfter "Text: "
.Collapse wdCollapseEnd
.Paste
.InsertAfter " - > "
cmt.Range.Copy
.InsertAfter "Comments: " & cmt.Initial & cmt.Index & ":"
.Collapse wdCollapseEnd
.Paste
.InsertParagraphAfter
End With
Next
End Sub
The difference here is that I'm using Copy and Paste rather than generating text strings.
Caveat: As the macro is written right now, any character formatting from the Scope (the text that appears next to Text in your file) will be applied to the arrow and the initials as well. This is pretty easy to fix with a search and replace, so I didn't incorporate it into the script.
Related
In MS Word (Office for Mac 2016, version 15.31) I would like to enrich a document by marking spelling errors and by writing the first spelling suggestion next to each misspelled word: for example if the text says
I wuld like to enrich
the result I need is
I [wuld][would] like to enrich
I know that
iErrorCnt=Doc.This.SpellingErrors.Count
For J=1 to iErrorCnt
Selection.TypeText Text:=DocThis.SpellingErrors(J)
Next J
will go through all spelling errors, and I know that
ActiveDocument.Words(1).GetSpellingSuggestions.Item(1).Name
allows to obtain the first spelling suggestion for a given word. But how do I link the misspelled word and the spelling suggestion (since the spelling suggestion is applied to words and words are indexed by integers) and how do I get them both marked in the document?
Try:
Sub SpellCheck()
Dim Rng As Range, oSuggestions As Variant
For Each Rng In ActiveDocument.Range.SpellingErrors
With Rng
If .GetSpellingSuggestions.Count > 0 Then
Set oSuggestions = .GetSpellingSuggestions
.Text = "[" & .Text & "][" & oSuggestions(1) & "]"
Else
.Text = "[" & .Text & "][]"
End If
End With
Next
End Sub
My problem is the following:
I want to define a range, including cells in my spreadsheet that contain formatted text (bold font), and turn it into any object that I can later use as the body for an outlook e-mail.
One of the ways I have tried so far is via the RangetoHTML function by Ron de Bruin (http://www.rondebruin.nl/win/s1/outlook/bmail2.htm). However, the function brings the text cells into another excel workbook which finally yields a table in the outlook e-mail. I want to keep the very same format that I start with in my excel cells. That is, it must be lines of ordinary text and not a table-like body in the mail.
That's my current code:
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Sheets("Preparation").Range("A90:A131")
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Thanks in advance for your help
Ron de Bruin’s RangeToHtml shows how to use Excel’s PublishObjects to convert a worksheet range to Html that can be used as the body of an email. I am sure this has helped thousands of developers.
The difficulty that RdeB overcomes is that PublishObjects is designed to create and maintain webpages. His routine outputs to a file and then reads that file because that is the only way to get the Html string required for the email body.
The difficulty that RdeB cannot overcome is that PublishObjects create poor quality, proprietary CSS. By “poor quality”, I mean that there is a lot of unnecessary CSS and that row heights and column widths are defined in points to give sizes suitable for a PC. By “proprietary”, I mean it uses styles such as mso-ignore:padding and mso-number-format:General that only Microsoft browsers are guaranteed to understand. It appears the major browsers are able to cope but many people have found that some newer browsers cannot cope and display rubbish.
To demonstrate this and to test my code, I created a worksheet based on your image. Rows 16 to 18 are right-aligned because I have specified this. Rows 20 to 22 are right aligned because this is the Excel default for numeric, date and time values. Its appearance is:
You can use your real data.
Copy this code to your workbook:
Option Explicit
Sub Test1()
Dim PathCrnt As String
Dim PathFileCrnt As String
Dim RngStr As String
Dim WshtName As String
PathCrnt = ThisWorkbook.Path & "\" ' ## Output to the same folder as workbook holding the macro
PathFileCrnt = PathCrnt & "Test1.html" ' ## Change if you do not like my filename
WshtName = "Sheet1" ' ## Change to your worksheet
RngStr = "A1:A28" ' ## Change to your range
With ThisWorkbook
With .PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=PathFileCrnt, _
Sheet:=WshtName, _
Source:=RngStr, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
End With
End Sub
You will need to change some of the statements near the top marked with ##
Run this macro to output your range to the file.
On my laptop, Microsoft Edge, Microsoft Internet Explorer and Google Chrome all display the file and all look the same although IE and Chrome are slow to display. The column is down the centre of the window:
There are none of the background grey cells and wide, white border you showed. However, I have not tried to display it within Outlook.
Now look at the file with your favourite text editor. Notice how much CSS is repeated. Notice how many style start “mso-” indicating they are Microsoft extensions. Notice the heights and widths measured in “pt” (points). Some Html display engines can cope but some cannot.
I suspect that PublishObjects has not been maintained. It was available with Excel 2003 and perhaps earlier. Some of the old Microsoft CSS extensions now have standard CSS equivalents but PublishObjects has not been updated to use them.
I have my own RangeToHtml written entirely in VBA. It will handle all formatting except borders. My code is far too big to post on Stack Overflow so I have extracted the bits you need. You apparently need bold or not bold and left or right alignment. I do not know if you specify right alignment or if you have numeric fields which right align by default so I handle both.
My function ColToHtml(range) returns a complete Html file for the first column of a range. My code does not create a temporary workbook or a temporary file. It produces clean, crisp Html and Css. It produces a table because you cannot have right-alignment outside a table. However, with no borders, it is not obvious the output is a table. The only difference in appearance is that the table is left aligned. If you prefer a centred table, it would be an easy change.
This was my test routine:
Sub Test2()
Dim Rng As Range
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
Debug.Print ColumnToHtml(Rng)
End Sub
It outputs the Html string to the Immediate Window. I then copied it to a file. I could have used VBA to write to a file but this was easier. When I opened the file with Microsoft Edge, it looked the same. Have a look at this second file with your favourite text editor. Notice how much smaller it is. The PublishObjects version is 6,901 bytes while this second version is 1,681 bytes. Notice how only standard Css is used and that the minimum of Css is used. This allows the display engine to make its own decisions about how to display the file based on the type of output device.
My last test was:
Sub Test3()
' This will need a reference to Microsoft Outlook nn.0 Outlook library
' where nn is the number of the Outlook version you are using.
Dim Rng As Range
Dim OutApp As Outlook.Application
Dim MailItemNew As Outlook.MailItem
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set MailItemNew = OutApp.CreateItem(olMailItem)
With MailItemNew
.BodyFormat = olFormatHTML
.HTMLBody = ColumnToHtml(Rng)
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set MailItemNew = Nothing
Set OutApp = Nothing
End Sub
This outputs the range to Outlook. I have used your code as a template but have referenced the Outlook library so I can use Outlook objects and constants. I had to reduce the font size to get it all on the screen at one time giving:
Again this has the same appearance except that the first letter of each line has been capitalized. I do not know how to stop the Outlook email editor doing this.
Incidentally, I selected the entire email and got the same appearance as in the image you posted.
The code for ColumnToHtml is below. Note that CellToHtml is the routine that actually creates the Html for a cell. It only handles bold and right alignment but it should be obvious that it would be easy to add other cell-level formats.
Function ColumnToHtml(ByRef RngCol As Range) As String
' Returns the first or only column of rng as a borderless table
' so it appears as a formatted list of rows.
Dim RngCell As Range
Dim RowCrnt As Long
Dim Table As String
' Build an Html table of the cells within the first column of RngCol
' ==================================================================
Table = Space(4) & "<table border=""0"">" & vbLf
For RowCrnt = RngCol.Row To RngCol.Row + RngCol.Rows.Count - 1
Set RngCell = RngCol.Worksheet.Cells(RowCrnt, RngCol.Column)
Table = Table & Space(6) & "<tr>" & CellToHtml(RngCell) & "</tr>" & vbLf
Next
Table = Table & Space(4) & "</table>"
' Build an Html file envelope around the table
' ============================================
ColumnToHtml = "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Frameset//EN""" & _
"""http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"">" & vbLf & _
"<html xmlns=""http://www.w3.org/1999/xhtml"" xml:lang=""en"" lang=""en"">" & vbLf & _
" <head></head>" & vbLf & _
" <meta http-equiv=""Content-Type""content=""text/html; charset=utf-8""/>" & vbLf & _
" <style>" & vbLf & _
" td.bold {font-weight:bold;}" & vbLf & _
" td.hAlign-right {text-align:right;}" & vbLf & _
" </style>" & vbLf & _
" </head>" & vbLf & _
" <body>" & vbLf & Table & vbLf & _
" </body>" & vbLf & _
"</html>"
End Function
Function CellToHtml(ByRef RngCell As Range) As String
' Convert a single cell to Html.
' This code handles: value, bold or not-bold (default) and left )default) or
' right-alignment.
' Note RngCell.Value is the value perhaps "1234" or "42999".
' and RngCell.Text is the display text perhaps "1,234" or "21-Sep-17".
' This is particularly important with dates and time where the
' value is unlikely to be what is displayed.
' Dates are held as days since 1-Jan-1900 and times are held as
' seconds-since-midnight / seconds-in-a-day. It is the NumberFormat that
' determine what you see.
Dim BoldCell As Boolean
Dim RAlignedCell As Boolean
Dim Style As String
Dim StyleNeeded As Boolean
CellToHtml = "<td"
' Add interior formatting here if required
If RngCell.Value = "" Then
' Ignore font and alignment formatting of empty cell.
Else
' Test for formats
BoldCell = False
RAlignedCell = False
Style = ""
StyleNeeded = False
If RngCell.Font.Bold Then
BoldCell = True
StyleNeeded = True
End If
If RngCell.HorizontalAlignment = xlRight Or _
(RngCell.HorizontalAlignment = xlGeneral And _
(IsNumeric(RngCell.Value) Or IsDate(RngCell.Value))) Then
RAlignedCell = True
StyleNeeded = True
End If
If StyleNeeded Then
CellToHtml = CellToHtml & " class="""
If BoldCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "bold"
End If
If RAlignedCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "hAlign-right"
End If
CellToHtml = CellToHtml & Style & """"
End If
End If
CellToHtml = CellToHtml & ">" ' Terminate "<td"
If RngCell.Value = "" Then
' Blank rows are displayed narrow. Use Non-blank space so display at homral width
CellToHtml = CellToHtml & " "
Else
CellToHtml = CellToHtml & RngCell.Text
End If
CellToHtml = CellToHtml & "</td>"
End Function
One last comment. You have not selected anything so I do not see the purpose of this code:
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With
Book endnotes often forgo superscript numbers for page numbers. E.g., instead of
Abe Lincoln was assassinated with a pistol.^33
:
33. A single-shot derringer pistol.
books by several authors write
Abe Lincoln was assassinated with a pistol.
:
Page 297. Abe Lincoln was shot single-shot derringer pistol.
Word doesn't have this feature, so I believe it would have to be a Macro. I came up with simple code below that loops through all of the endnotes and adds
"Page ???. "
before each endnote, but what does "???" need to be to correctly insert the page number in my manuscript that the citation's located on?
Sub RedefineExistingEndNotes()
Dim fn As Endnote
For Each fn In ActiveDocument.Endnotes
fn.Range.Paragraphs(1).Range.Font.Reset
fn.Range.Paragraphs(1).Range.Characters(1).InsertBefore "Page" & "???" & " - "
Next fn
End Sub
Try the below VBA code:
Sub InsertPageNumberForEndnotes()
Dim endNoteCount As Integer
Dim curPageNumber As Integer
If ActiveDocument.Endnotes.Count > 0 Then
For endNoteCount = 1 To ActiveDocument.Endnotes.Count
Selection.GoTo What:=wdGoToEndnote, Which:=wdGoToAbsolute, Count:=endNoteCount
curPageNumber = Selection.Information(wdActiveEndPageNumber)
ActiveDocument.Endnotes(endNoteCount).Range.Select
ActiveDocument.Application.Selection.Collapse (WdCollapseDirection.wdCollapseStart)
ActiveDocument.Application.Selection.Paragraphs(1).Range.Characters(1).InsertBefore "Page " & CStr(curPageNumber) & " - "
Next
End If
End Sub
An alternative might be to use PAGEREF fields and hide the endnote references, e.g.
Sub modifyEndNotes()
Const bookmarkText As String = "endnote"
Dim en As Word.Endnote
Dim rng As Word.Range
For Each en In ActiveDocument.Endnotes
en.Reference.Bookmarks.Add bookmarkText & en.Index
en.Reference.Font.Hidden = True
Set rng = en.Range
rng.Paragraphs(1).Range.Font.Hidden = True
rng.Collapse WdCollapseDirection.wdCollapseStart
rng.Text = "Page . "
rng.SetRange rng.End - 2, rng.End - 2
rng.Fields.Add rng, WdFieldType.wdFieldEmpty, "PAGEREF " & bookmarkText & en.Index & " \h", False
'if necessary...
'rng.Fields.Update
en.Range.Font.Hidden = False
Next
Set rng = Nothing
End Sub
For a second run, you'd need to remove and re-insert the text and fields you had added.
Unfortunately, a further look suggests that it would be difficult, if not impossible, to hide the endnote references (in the endnotes themselves) without hiding the paragraph marker at the end of the first endnote para, which means that all the endnotes will end up looking like a single messy note. So I deleted this Answer.
However, the OP thought the approach could be modified in a useful way so I have undeleted. I can't re-research it right away but some possibilities might be to replace every endnote mark by a bullet (as suggested by the OP) or perhaps even something as simple as a space or a "-".
For example, something like this (which also hides the references using a different technique)...
Sub modifyEndNotes2()
' this version also formats the endnotes under page headings
Const bookmarkText As String = "endnote"
Dim en As Word.Endnote
Dim f As Word.Field
Dim i As Integer
Dim rng As Word.Range
Dim strSavedPage As String
strSavedPage = ""
For Each en In ActiveDocument.Endnotes
en.Reference.Bookmarks.Add bookmarkText & en.Index
Set rng = en.Range
rng.Collapse WdCollapseDirection.wdCollapseStart
If CStr(en.Reference.Information(wdActiveEndPageNumber)) <> strSavedPage Then
strSavedPage = CStr(en.Reference.Information(wdActiveEndPageNumber))
rng.Text = "Page :-" & vbCr & " - "
rng.SetRange rng.End - 6, rng.End - 6
rng.Fields.Add rng, WdFieldType.wdFieldEmpty, "PAGEREF " & bookmarkText & en.Index & " \h", False
rng.Collapse WdCollapseDirection.wdCollapseEnd
Else
rng.Text = "- "
End If
Next
If ActiveDocument.Endnotes.Count > 1 Then
ActiveDocument.Styles(wdStyleEndnoteReference).Font.Hidden = True
Else
ActiveDocument.Styles(wdStyleEndnoteReference).Font.Hidden = False
End If
Set rng = Nothing
End Sub
In the above case, notice that there is only one link to each page, that formatting might be needed to make it obvious that it is a link, and so on.
I am using the following VBA macro to add page numbers after all bookmark hyperlinks in my document:
Sub InsertPageRefs()
Application.ScreenUpdating = False
Dim hLnk As Hyperlink, Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
With hLnk
If InStr(.SubAddress, "_Toc") = 0 And .Address = "" Then
Set Rng = .Range
With Rng
.Collapse Direction:=wdCollapseEnd
.InsertAfter Text:=" (See page #)"
.Font.Underline = wdUnderlineNone
End With
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), Text:="PAGEREF " & .SubAddress
End If
End With
Next
Set Rng = Nothing
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
However, it's having undesirable results.
The blue color of the hyperlinks is partially spilling over into the added text.
It's creating a bunch of crazy span tags when I save the resulting file to HTML. I don't want this because I am going to convert the HTML to .mobi for Kindle and all the span tags are going to create chaos in my .mobi.
How do I strip out all the formatting and insert the page numbers in the "Normal" word style?
I suspect the real answer for this would be to use a good e-book editor that will keep track of this for you.
That said, the problem is likely that you are working on the Hyperlink's range, so all you should have to do is duplicate it. This allows the formatting of your range separate itself from whatever formatting is attached to the hyperlink. The other benefit of using a duplicate of a Hyperlink's range is that you can operate on the text of the range directly without destroying the link, which is also an easy way to preserve the target formatting:
Sub InsertPageRefs()
Dim hLnk As Hyperlink
Dim Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
If InStr(hLnk.SubAddress, "_Toc") = 0 And hLnk.Address = vbNullString Then
Set Rng = hLnk.Range.Duplicate
Rng.Start = Rng.End
Rng.Text = " (See page #)"
Rng.Font.Underline = wdUnderlineNone
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), _
Text:="PAGEREF " & hLnk.SubAddress
End If
Next
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
Note that I pulled out the With blocks to make this more readable. Nested Withs make it a lot more difficult to tell at a glance what object you're operating on.
I am trying to use VBA to move a rich text clause ("strText"), which appears at the beginning of various paragraphs, to the end of each paragraph where the clause appears, and thereafter to underline strText.
I am a novice/hobbyist at vba programming, so please be gentle. I spent a few days on this before seeking help.
Problems with my attempted coding (which appears below):
I tried to assign to var "LparaNo" the number of the paragraph wherein the found text (strText) appears. But the number that "LparaNo" returns is totally off base.
If someone has a suggestion about how to get the right paragraph number, I'd appreciate it.
My intention is to set a range variable objRange_ParaHoldingText= ActiveDocument.Paragraphs(LparaNo).Range, i.e., a range that would reflect the paragraph in which the sought text was found.
I can't figure out how to move objRange01 ("strText", which is formatted text) to the end of the paragraph in which it appears.
Any suggestions would be much appreciated.
Thanks, Marc
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03()
' Code canniablized from http://stackoverflow.com/questions/11733766/how-to-search-for-text-and-check-for-underline-in-vba-for-word
Dim c As Range
Dim fnd As String
Dim strText As String
Dim objRange01 As Range
Dim objRange02 As Range
Dim objRange03 As Range
Dim LparaNo As Long
Dim strParazText As String
With ActiveDocument
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
' My objectives are: (1) to move strText from the beginning of various paragraphs, to the end of each paragraph where it appears,
' and thereafter, (2) to delete the ":" at the end of strText, and (3) to underline strText
fnd = strText
If fnd = "" Then Exit Sub
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = fnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
c.Find.Execute
While c.Find.Found
c.Select ' I am trying to select the text that was found
Set objRange01 = c ' I am trying to set objRange01 = the text that was found, and selected
Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend ' I am extending the selection to include the entire paragraph
Set objRange02 = Selection.Range 'The entire paragraph
Set objRange03 = ActiveDocument.Range(Start:=0, End:=Selection.End) ' I am trying to set objRange02 = all text from
' ' beginning of doc thru objRange01.text
LparaNo = objRange03.ComputeStatistics(wdStatisticParagraphs) + 1 ' I am trying to set LparaNo = the no. of paras in all
' ' text from beginning of doc thru the end of objRange02.
' ' Alas, the number generated for "LparaNo" is incorrect. The paragraph number generated for "LparaNo"
' ' is the number for a paragraph that appears 5 pages before objRange01.text
MsgBox "Paragraph # " & LparaNo & " [objRange01.Text = c = ] " & Chr(34) & objRange01.Text & Chr(34) & vbCrLf & _
vbCrLf & objRange02.Text & vbCrLf & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 2).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 1).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo).Range.Text & vbCrLf ' & _
' ActiveDocument.Paragraphs(LparaNo + 1).Text & vbCrLf & _
' ActiveDocument.Paragraphs(LparaNo + 2).Range.Text & vbCrLf '& _
objRange01.Move Unit:=wdParagraph, Count:=1 ' I am trying unsuccessfully to move the selected text to the beginning
' ' of the next paragraph
objRange01.Move Unit:=wdCharacter, Count:=-1 ' I am trying unsuccessfully to move the selected text from the beginning
' ' of the next paragraph, to the end of the preceding paragraph, i.e.,
' ' to the end of the selected text's paragraph of origin.
c.Find.Execute
Wend ' While c.Find.Found
End With
End Sub 'subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03
Here is a suggestion that doesn't use Find. If you want to use Find, you'll need to loop, which can be tricky if there's any risk of finding the same text more than once. Instead, my solution loops through the Paragraphs collection. Does this get at what you're after?
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_04()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.Content
Dim currPara As Paragraph
Dim strText As String
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
Dim i As Long
' Set a counter to indicate the paragraph. This should be sufficient,
' unless your document is complicated in a way I cannot predict.
i = 0
' Loop through the paragraphs in the active document.
For Each currPara In docRng.Paragraphs
i = i + 1
' Check each paragraph for a match to strText. By using Mid you eliminate
' the chance of finding the string somewhere else in the text. This will work
' for different strText values.
If Mid(currPara.Range.Text, 1, Len(strText)) = strText Then
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End)
' Adds a space at the end of the paragraph. If you don't want the space,
' just delete the InsertAfter method. MoveEnd is used to bring the end of the
' range before the paragraph marker.
With currRng
.MoveEnd Unit:=wdCharacter, Count:=-1
.InsertAfter " "
End With
Set strRng = currDoc.Range(currRng.Start, currRng.Start + Len(strText))
' Set a range for the string, underline it, cut it, paste it at the end of the
' paragraph (again, before the paragraph marker), and select it. Note that moving
' a range doesn't move the text in it. Cut and paste does that.
With strRng
.Underline = wdUnderlineSingle
.Cut
.Move Unit:=wdParagraph, Count:=1
.Move Unit:=wdCharacter, Count:=-1
.Paste
.Select
End With
' Collapse the selection to the end of the text and backspace three times to
' remove the colon and two spaces. If these final characters are variable, you'll
' want something spiffier than this.
With Selection
.Collapse wdCollapseEnd
.TypeBackspace
.TypeBackspace
.TypeBackspace
End With
' Expand the range we've been using to hold the paragraph so that it includes the newly
' pasted text.
currRng.Expand wdParagraph
' I wasn't entirely sure what you wanted to convey in your message box. This displays
' the paragraph number and the new text of the paragraph.
MsgBox "Paragraph # " & i & " [currRng.Text = ] " & Chr(34) & currRng.Text
End If
Next currPara
End Sub