Search & Replace using Document.Content Doesn't Include Footers

RMittelman · #1 11-21-2021, 12:26 PM

I'm trying to automate Word MailMerge from Access VBA. It's mostly working, but having a strange quirk.

My paragraph text is stored in Access tables in Long Text fields, NOT designated as rich text. I've found that if the text (in Access) contains "smart" quotes and apostrophes, it messes up my code execution and causes errors such as making it look like there are too many fields in the merge data source. Therefore, I make sure all quotes and apostrophes are "plain" ( ' or " ).

Instead of long text fields being in my merge data file, I'm doing a "hybrid" merge where I first populate long text into bookmarks, then do the merge. I only do this for document content which is the same for every document.

Just before the actual merge, I run code to replace the "plain" apostrophes and quotes with "smart" versions, using this code, which relies on Regex:

Code:

    ' first replace open-apostrophes and open-quotes
    With oRegex
        .Pattern = " '| """
        .Global = True
        .IgnoreCase = True
        Set oMatches = .Execute(WordDoc.Content)
    End With
    If oMatches.Count > 0 Then
        For Each oMatch In oMatches
            matchText = oMatch.Value
            With WordDoc.Content.Find
                .Text = oMatch.Value
                .Replacement.Text = Switch(oMatch = " '", " " & Chr$(145), oMatch = " """, " " & Chr$(147))
                .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
            End With
        Next
    End If ' open-apostrophes or open-quotes found
    
    ' now replace single apostrophes and quotes (handles close-quotes, close-apostrophes and individual apostrophes
    With oRegex
        .Pattern = "'|"""
        .Global = True
        .IgnoreCase = True
        Set oMatches = .Execute(WordDoc.Content)
    End With
    If oMatches.Count > 0 Then
        For Each oMatch In oMatches
            matchText = oMatch.Value
            With WordDoc.Content.Find
                .Text = oMatch.Value
                .Replacement.Text = Switch(oMatch = "'", Chr$(146), oMatch = """", Chr$(148))
                .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
            End With
        Next
    End If ' single apostrophes or quotes found

Notice I'm using WordDoc.Content, which I assume means ALL content.

When I finish this code execution, I notice that everything works fine except for text in my document footer. This does not get replaced by smart quotes.

I even tried single-stepping through the code and tried replacing WordDoc.Content with WordDoc.StoryRanges(9), which happens to be the footer in my document. This returned a Regex match, but the code would not cause the quotes to be replaced with smart quotes.

So the questions are:

Why doesn't WordDoc.Content include the footer text?

Why doesn't the code work when I use the proper StoryRange.Text? I even tried manually activating the footer while running my code, but no luck.

Thanks in advance for any insight here...

gmayor · #2 11-21-2021, 10:37 PM

As you are probably aware, a Word document comprises several separate story ranges, a bit like a pile of transparencies (if you are old enough to remember them) that combine to make the whole. I believe 'Content' reflects only the main story range.

To be certain of processing all the story ranges you need to do so separately and the following code, based on Word code from my web site, should do that.

I don't work in Access, but it works in Excel where the principle is similar:

Code:

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Nov 2021 

 
Sub ReplaceInStoryRanges()
Const sPath As String = "C:\Path\docname.docx" ' the path of the document
Dim WordDoc As Object
Dim wdApp As Object
Dim oStory As Object
Dim oShp As Object
Dim bFormat As Boolean

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set WordDoc = wdApp.Documents.Open(sPath) 'works in Word even if the document is already open

    bFormat = wdApp.Options.AutoFormatAsYouTypeReplaceQuotes
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = False
    For Each oStory In WordDoc.StoryRanges
        Select Case oStory.StoryType
            Case 1 To 11
                Do
                    ReplaceQuotes wdApp, WordDoc, oStory
                    DoEvents
                    On Error GoTo 0
                    Select Case oStory.StoryType
                        Case 6, 7, 8, 9, 10, 11
                            If oStory.ShapeRange.Count > 0 Then
                                For Each oShp In oStory.ShapeRange
                                    If oShp.TextFrame.HasText Then
                                        ReplaceQuotes wdApp, WordDoc, oStory
                                    End If
                                    DoEvents
                                Next oShp
                            End If
                        Case Else
                    End Select
                    On Error GoTo 0
                    Set oStory = oStory.NextStoryRange
                Loop Until oStory Is Nothing
            Case Else
        End Select
        DoEvents
    Next oStory
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = bFormat
End Sub

Sub ReplaceQuotes(wdApp As Object, oDoc As Object, oRng As Object)
Dim oFind As Object
Dim vFindText As Variant
Dim vReplText As Variant
Dim bQuotes As String
Dim i As Long
    vFindText = Array(Chr(132), Chr(147), Chr(148), ChrW(171) & ChrW(160), ChrW(160) & ChrW(187), Chr(145), Chr(146))
    vReplText = Array(Chr(34), Chr(34), Chr(34), Chr(34), Chr(34), Chr(39), Chr(39))
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = False
    For i = LBound(vFindText) To UBound(vFindText)
        Set oFind = oRng.Duplicate
        With oFind.Find
            Do While .Execute(vFindText(i))
                oFind.Text = vReplText(i)
                oFind.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Set oFind = Nothing
    Exit Sub
End Sub

RMittelman · #3 11-22-2021, 01:40 PM

Thanks GMayor. Great example. In the meantime, I've been working on this and came up with the following code:

Code:

'---------------------------------------------------------------------------------------
' Procedure         : replace_quotes_with_smart_quotes
' Author            : RMittelman@gmail.com
'
' Purpose           : Replaces plain apostrophes & quotes with Word smart quotes
'
' History           :   11/14/2021  Initial version
'                       11/20/2021  Replaced Regex code with Word Find code
'
' Returns           : Boolean indicating success or failure.
'
' Notes             :
'
'---------------------------------------------------------------------------------------
'
Private Function replace_quotes_with_smart_quotes() As Boolean

    Dim myStoryRange    As Object
    Dim arFind          As Variant
    Dim arReplace       As Variant
    Dim i               As Integer
    
    replace_quotes_with_smart_quotes = False
    On Error GoTo error_handler
    
    arFind = Array(" '", "'", " """, """")
    arReplace = Array(Chr$(145), Chr$(146), Chr$(147), Chr$(148))
    
    For Each myStoryRange In WordDoc.StoryRanges
        With myStoryRange.Find
            
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .ClearFormatting
            
            For i = 0 To UBound(arFind)
                .Text = arFind(i)
                .Replacement.Text = arReplace(i)
                .Replacement.ClearFormatting
                .Replacement.Highlight = False
                .Execute Replace:=wdReplaceAll
            Next
            
        End With
    Next myStoryRange

    replace_quotes_with_smart_quotes = True
    
exit_handler:
    
    On Error Resume Next
    Set myStoryRange = Nothing
    Exit Function
    
error_handler:
    
    m_LastError = Err.Description
    If MsgBoxEx(Err.Description, vbRetryCancel + vbExclamation + vbDefaultButton2, "Error " & Err.Number, , , vbRed, , "&Debug", "&Exit") = vbRetry Then
        Stop
        Resume
    End If
    
    replace_quotes_with_smart_quotes = False
    Resume exit_handler

End Function

Somewhat similar to what you did. Not familiar enough with story ranges to understand what you did, or why some of the types require you to do the replacing again.

Looping through the story ranges in a for each loop seems to work, but now I'm concerned that it may fail under certain circumstances.

I'd appreciate knowing what's going on in your code, because I'm using my technique to replace other things in the document also.

Access rich text is totally confusing to Word, so I can't simply place my rich text paragraphs from access storage into a Word document. So I'm using plain text with codes like "<e>", "<se>" & "<ce>" in my paragraph text and then popping them into the Word document and replacing them with {Enter}, {Shift-Enter} & {Ctrl-Enter} Word codes. This seems to work, but now I'm concerned that I'm not using story types and text frames and such.

Thanks again...

gmayor · #4 11-23-2021, 01:16 AM

I have repeated my code with annotation and restricted the called sub to convert only English smart quotes. I am not processing ranges twice. I am processing ranges within ranges, such as text boxes in the header/footer which require a touch of brute force.

Code:

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 23 Nov 2021

 
Sub ReplaceInStoryRanges()
Const sPath As String = "C:\Path\docname.docx" ' the path of the document
Dim WordDoc As Object
Dim wdApp As Object
Dim oStory As Object
Dim oShp As Object
Dim bFormat As Boolean

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set WordDoc = wdApp.Documents.Open(sPath) 'works in Word even if the document is already open
    
    'record autoformat option
    bFormat = wdApp.Options.AutoFormatAsYouTypeReplaceQuotes
    'set autoformat option to off
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = False
    'process each storyrange by enumeration
    For Each oStory In WordDoc.StoryRanges
        Select Case oStory.StoryType
            Case 1 To 11 'the principle storyranges
            'see https://apireference.aspose.com/words/net/aspose.words/storytype)
                Do
                    ReplaceQuotes wdApp, WordDoc, oStory 'run the external sub
                    DoEvents
                    On Error GoTo 0
                    Select Case oStory.StoryType
                        Case 6, 7, 8, 9, 10, 11 'header/footer ranges
                            'process text boxes etc in the header/footer ranges separately
                            If oStory.ShapeRange.Count > 0 Then
                                For Each oShp In oStory.ShapeRange
                                    If oShp.TextFrame.HasText Then
                                        ReplaceQuotes wdApp, WordDoc, oStory 'run the external sub
                                    End If
                                    DoEvents
                                Next oShp
                            End If
                        Case Else
                    End Select
                    On Error GoTo 0
                    Set oStory = oStory.NextStoryRange
                Loop Until oStory Is Nothing
            Case Else
        End Select
        DoEvents
    Next oStory
    'restore original autoformat option
    wdApp.Options.AutoFormatAsYouTypeReplaceQuotes = bFormat
End Sub

Sub ReplaceQuotes(wdApp As Object, oDoc As Object, oRng As Object)
Dim oFind As Object
Dim vFindText As Variant
Dim vReplText As Variant
Dim bQuotes As String
Dim i As Long
    vFindText = Array(Chr(147), Chr(148), Chr(145), Chr(146))
    vReplText = Array(Chr(34), Chr(34), Chr(39), Chr(39))
    For i = LBound(vFindText) To UBound(vFindText)
        Set oFind = oRng.Duplicate
        With oFind.Find
            Do While .Execute(vFindText(i))
                oFind.Text = vReplText(i)
                oFind.Collapse 0
            Loop
        End With
    Next i
lbl_Exit:
    Set oFind = Nothing
    Exit Sub
End Sub

RMittelman · #5 12-28-2021, 02:01 PM

Hi GMayor,

I'm playing with your code, and I'm confused by something.

The code loops through the story ranges, only processing types 1 - 11. That I understand. If the story type is 6 - 11 (headers & footers), it process them again if they have a shape range count >0. Also, they only process if they have a TextFrame with .HasText true. I presume these are text boxes in the headers/footers, and you want to replace text in those text boxes.

So this brings up 2 questions:
1: What if there are text boxes NOT in a header or footer? This seems to ignore that possibility.

2: The code sends the oStory object to the subroutine, but that was already done before, right? If you want to replace text in the text box(es), shouldn't you be sending the text box range to the subroutine instead of the oStory range, which has already been processed? If this is so, what object should you send the second time? I can't seem to find a text range object in the Word object model under StoryRanges or ShapeRange.TextFrame. Do you have any ideas on this?

Please forgive if my understanding of your code is faulty.

Thanks...

P.S. I've been using a simplified version which loops through each StoryRange and does the find and replace without worrying about shapes. Seems to work fine, but I'm curious about your code.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Help to include header and footer in string search code which i already have.	branko	Word VBA	1	03-28-2017 11:50 PM
Need some vba code to search a word document an replace it if len = 3	Belleke	Word VBA	3	10-24-2016 01:00 AM
Table of content to not include TOC as first section!?	neuroscientist911	Word	4	11-19-2014 07:55 AM
Windows Search Does Not Include Outlook	jkingston	Outlook	0	07-20-2014 08:43 AM
Looking for Windows Search app with ability to search by content	gopher_everett	Office	1	02-28-2013 09:23 PM