Consulting

Results 1 to 11 of 11

Thread: macro fails on 2nd run

  1. #1
    VBAX Newbie
    Joined
    May 2021
    Posts
    5
    Location

    macro fails on 2nd run

    Hi All,

    I have a longish userform macro in Word that highlights defined terms in legal documents in different colors depending on if they are defined more than once (in quotes), defined but not used, and then every instance of the term.

    This all works perfectly on the first run of a document, however, if I run it again on a 2nd document, it jumps out of one of the loops and goes to the next phase of the routine, ending prematurely.

    If I close and restart Word, it runs perfectly again, but fails on 2nd attempt. It appears to fail when changing from the main story to the footnote story (highlighted in red) below. This is just the bit of code where it fails - please let me know if anyone would like to see the whole thing.

    Has anyone had a similar issue? Many thanks for any help!



    With Selection
        .HomeKey wdStory
       
     
            'highlight all copies yellow
     
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdYellow
                i = i + 1
                ActiveDocument.UndoClear
            Loop
           
    If ActiveDocument.Footnotes.Count >= 1 Then
     
           
                ActiveDocument.StoryRanges(wdFootnotesStory).Select
               
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdYellow
                i = i + 1
                ActiveDocument.UndoClear
            Loop
    End If
     
    ActiveDocument.StoryRanges(wdMainTextStory).Select
    Last edited by macropod; 05-09-2021 at 02:00 PM. Reason: Added code tags

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,617
    Location
    Try using a variable set to Active Document
    Dim TheDoc as Object
    
    'Near the top of your Code
    Set TheDoc = ActiveDocument
    Replace all other instances of "ActiveDocument" in code with "TheDoc"
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,311
    Location
    To make that work reliably, one would also need to replace:
    With Selection
        .HomeKey wdStory
    with:
    With TheDoc
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  4. #4
    VBAX Newbie
    Joined
    May 2021
    Posts
    5
    Location
    Quote Originally Posted by SamT View Post
    Try using a variable set to Active Document
    Dim TheDoc as Object
    
    'Near the top of your Code
    Set TheDoc = ActiveDocument
    Replace all other instances of "ActiveDocument" in code with "TheDoc"

    Thank you - just tried it, but still having the same issue . . .

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,311
    Location
    Unfortunately, you haven't posted enough of your code to diagnose the issue. Try something along the lines of:
    Sub Demo()
    Application.ScreenUpdating = False
    Dim wdDoc As Document, StrFnd As String, i As Long
    Set wdDoc = ActiveDocument
    StrFnd = InputBox("Text to find")
    If Trim(StrFnd) = "" Then Exit Sub
    With wdDoc
      i = i + Counter(StrFnd, .StoryRanges(wdMainTextStory))
      i = i + Counter(StrFnd, .StoryRanges(wdFootnotesStory))
      .UndoClear
    End With
    MsgBox i
    Application.ScreenUpdating = True
    End Sub
    
    
    Function Counter(StrFnd As String, Rng As Range) As Long
    Dim i As Long
    With Rng
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        Do While .Execute(FindText:=StrFnd, _
          MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
            Wrap:=wdFindStop, Forward:=True) = True
          .Parent.HighlightColorIndex = wdYellow
          i = i + 1
        Loop
      End With
    End With
    Counter = i
    End Function
    Last edited by macropod; 05-09-2021 at 10:59 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Newbie
    Joined
    May 2021
    Posts
    5
    Location
    Quote Originally Posted by macropod View Post
    Unfortunately, you haven't posted enough of your code to diagnose the issue.

    Thanks so much for your assistance! The procedure is quite long, so not sure how much to post . . .

    It finds a start quote, extends to the end quote, puts the term in a variable, and loops through every term in the document, first those in the main story, then starting again from the footnotes, if the term is defined there. It highlights if defined more than once (in quotes more than once - turquoise), each instance without quotes (yellow), and if defined, but not used (in quotes, but never used again - red).

    The big question for me is why it would work correctly on any document once, even in documents 100's of pages long, but then require a fresh process of Word to run correctly a 2nd time.
    Last edited by macropod; 05-09-2021 at 11:01 PM. Reason: Deleted unnecessary quote of entire post relied to

  7. #7
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,311
    Location
    Based on your description, try:
    Option ExplicitDim StrTerms As String, i As Long, j As Long, bFnd As Boolean
    
    
    Sub Demo()
    Application.ScreenUpdating = False
    Dim StrFnd As String
    StrTerms = "|"
    With ActiveDocument
      Call GetTerms(.StoryRanges(wdMainTextStory))
       If .Footnotes.Count > 0 Then Call GetTerms(.StoryRanges(wdFootnotesStory))
      StrTerms = Replace(Replace(StrTerms, "“", ""), "”", "")
      For i = UBound(Split(StrTerms, "|")) - 1 To 1 Step -1
        j = 0: StrFnd = Split(StrTerms, "|")(i)
        Call RngTag(.StoryRanges(wdMainTextStory), StrFnd)
        If .Footnotes.Count > 0 Then Call RngTag(.StoryRanges(wdFootnotesStory), StrFnd)
        If j = 0 Then
          StrTerms = Replace(StrTerms, StrFnd & "|", "")
        End If
      Next
      For i = 1 To UBound(Split(StrTerms, "|")) - 1
        StrFnd = Split(StrTerms, "|")(i)
        Call TermTag(.StoryRanges(wdMainTextStory), StrFnd)
        If .Footnotes.Count > 0 Then
          If bFnd = False Then Call TermTag(.StoryRanges(wdFootnotesStory), StrFnd)
        End If
      Next
    End With
    Application.ScreenUpdating = True
    End Sub
    
    
    Sub GetTerms(Rng As Range)
    Options.DefaultHighlightColorIndex = wdRed
    With Rng
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = True
        .Forward = True
        .MatchWildcards = True
        .Wrap = wdFindContinue
        .Text = """"
        .Replacement.Text = "^&"
        .Execute Replace:=wdReplaceAll
        .Text = "“*”"
        .Replacement.Text = "^&"
        .Replacement.Highlight = True
        .Execute Replace:=wdReplaceAll
        .Format = False
        .Wrap = wdFindStop
      End With
      Do While .Find.Execute
        If InStr(StrTerms, .Text) = 0 Then
          StrTerms = StrTerms & .Text & "|"
        Else
          .HighlightColorIndex = wdTurquoise
        End If
        .Collapse wdCollapseEnd
      Loop
    End With
    End Sub
    
    
    Sub RngTag(Rng As Range, StrFnd As String)
    With Rng
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .MatchWildcards = True
        .Text = "[!“]" & StrFnd & "[!”]"
        .Wrap = wdFindStop
      End With
      Do While .Find.Execute
        j = j + 1
        .Start = .Start + 1
        .End = .End - 1
        .HighlightColorIndex = wdYellow
        .Collapse wdCollapseEnd
      Loop
    End With
    End Sub
    
    
    Sub TermTag(Rng As Range, StrFnd As String)
    bFnd = False
    With Rng
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .MatchWildcards = True
        .Text = "“" & StrFnd & "”"
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found Then
        .HighlightColorIndex = wdYellow
        bFnd = True
      End If
    End With
    End Sub
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  8. #8
    VBAX Newbie
    Joined
    May 2021
    Posts
    5
    Location
    Quote Originally Posted by macropod View Post
    Based on your description, try:
    Paul, sorry for the late response - been crazy at work . . . thank you so much for writing this, but I couldn't get it to run . . . my VBA skills are rudimentary, at best. Here's the whole code - I'll cut out the footnote section, which is basically the same, but starts in the footnotes, in case a term is defined there. Hope it's not too long!

    Sub HighlightDefs()
    HighlightWork1.Show vbModeless
    End Sub
     
     
    Private Sub cmdAll_Click()
     
            '1. Highlight Defined Terms
     
    Dim i As Integer
    Dim j As Integer
    Dim R1 As Integer
    Dim R2 As Integer
    Dim R3 As Integer
    Dim r4 As Integer
    Dim oRng As Word.Range
    Dim oRng2 As Word.Range
    Dim NumCharsBefore As Long, NumCharsAfter As Long, LengthsAreEqual As Boolean
    Dim StrFind As String
    Dim StrReplace As String
    Dim StrReplace2 As String
    Dim StrFind2 As String
    Dim Length As Integer
    Dim varText As String
    Dim myRange As Range
     
    Dim char As String
    Dim myNum As Integer
    Dim myNum2 As Integer
    Dim myNum3 As Integer
     
    Dim bSmtQt As Boolean
     
     
    i = 0
    j = 0
    R1 = 0
    R2 = 0
    R3 = 0
    r4 = 0
     
    Dim nCount As Long
        nCount = 0
     
    ActiveDocument.UndoClear
     
     
    On Error GoTo Out3
     
    ActiveDocument.ActiveWindow.View.Type = wdPrintView
     
     
    'Application.ScreenUpdating = False
     
            'replace straight quotes with smart quotes
     
    bSmtQt = Options.AutoFormatAsYouTypeReplaceQuotes
    Options.AutoFormatAsYouTypeReplaceQuotes = True
    With ActiveDocument.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = """"
      .Replacement.Text = """"
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
     
     
     
    If ActiveDocument.Footnotes.Count >= 1 Then
     
    ActiveDocument.StoryRanges(wdFootnotesStory).Select
     
     
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = """"
      .Replacement.Text = """"
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.AutoFormatAsYouTypeReplaceQuotes = bSmtQt
     
     
    End If
    
     
    With Selection
        .HomeKey wdStory
    End With
     
        'find unmatched quotes
     
    Dim oPara As Paragraph
    For Each oPara In ActiveDocument.Paragraphs
      With oPara.Range
        If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
          .Select
          MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
           
            If varText = vbOK Then
                Exit Sub
            End If
     
          Unload Me
        Exit Sub
        End If
        If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
          .Select
          MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
           
            If varText = vbOK Then
                Exit Sub
            End If
     
          Unload Me
        Exit Sub
        End If
      End With
    Next
     
     
    Dim oFoot As Footnote
    For Each oFoot In ActiveDocument.Footnotes
      With oFoot.Range
        If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
          .Select
          MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
           
            If varText = vbOK Then
                Exit Sub
            End If
     
          Unload Me
        Exit Sub
        End If
        If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
          .Select
          MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
           
            If varText = vbOK Then
                Exit Sub
            End If
     
          Unload Me
        Exit Sub
        End If
      End With
    Next
     
     
    ActiveDocument.UndoClear
     
    i = 0
     
            'insert text to mark end of replacements
     
        Selection.HomeKey unit:=wdStory
        Selection.TypeText Text:=Chr(147) & "xyxy" & Chr(148) & " "
     
       
    Do
     
            'A. find quote for next term
     
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^0147"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
       
    Set myRange = Selection.Range
     
     
    If Selection.Range.HighlightColorIndex = wdTurquoise Then
        With Selection.Find
            .Text = "^0148"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
       
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^0147"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    Else
    End If
    
     
            '2. find close quote and select
       
        Selection.Extend
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^0148"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
        
        
         Selection.ExtendMode = False
        
     
    StrFind = Selection.Text
    StrReplace = Selection.Text
    Length = Len(StrReplace) - 2
     
     
            'set second variable for plural
     
    If Length > 1 Then
    StrFind2 = Mid$(StrReplace, 1, Length) & Chr(148)
    StrReplace2 = Mid$(StrReplace, 1, Length) & Chr(148)
    Else
    End If
     
            'skip certain words
     
    If Mid$(StrFind, 2, 2) = "or" And Len(StrFind) = 4 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "or," And Len(StrFind) = 5 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 2) = "to" And Len(StrFind) = 4 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "to," And Len(StrFind) = 5 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Len(StrFind) = 3 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "and" And Len(StrFind) = 5 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 4) = "and," And Len(StrFind) = 6 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "our" And Len(StrFind) = 5 Then
       Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 4) = "our," And Len(StrFind) = 6 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 2) = "we" And Len(StrFind) = 4 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "we," And Len(StrFind) = 5 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 2) = "us" And Len(StrFind) = 4 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
    If Mid$(StrFind, 2, 3) = "us," And Len(StrFind) = 5 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    End If
     
     
     
          Set myRange = Selection.Range
         
         
            'check if back at the beginning
         
    If myRange = Chr(147) & "xyxy" & Chr(148) _
    Or myRange = Chr(147) & "Xyxy" & Chr(148) _
    Or myRange = Chr(147) & "XYXY" & Chr(148) Then
        GoTo Skip3
    Else
    End If
         
          
    
            'skip if string is too long
     
    If Len(StrFind) > 254 Then
        Selection.Collapse Direction:=wdCollapseEnd
        GoTo Skip
    Else
    End If
     
     
    With Selection
        .HomeKey wdStory
     
            'replace terms defined more than once
     
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=StrFind, _
                MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdTurquoise
                i = i + 1
                ActiveDocument.UndoClear
            Loop
     
           
                Selection.HomeKey wdStory
               
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng2 = Selection.Range
                oRng2.HighlightColorIndex = wdTurquoise
                j = j + 1
                ActiveDocument.UndoClear
            Loop
     
     
    If ActiveDocument.Footnotes.Count >= 1 Then
     
                ActiveDocument.StoryRanges(wdFootnotesStory).Select
                
                Selection.HomeKey
               
                Do While .Execute(FindText:=StrFind, _
                    MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                    Wrap:=wdFindStop, Forward:=True) = True
                    Set oRng = Selection.Range
                    oRng.HighlightColorIndex = wdTurquoise
                    i = i + 1
                    ActiveDocument.UndoClear
                Loop
               
                Selection.HomeKey
               
                Do While .Execute(FindText:=StrFind2, _
                    MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
                    Wrap:=wdFindStop, Forward:=True) = True
                    Set oRng2 = Selection.Range
                    oRng2.HighlightColorIndex = wdTurquoise
                    j = j + 1
                    ActiveDocument.UndoClear
                Loop
    End If
     
     
    ActiveDocument.StoryRanges(wdMainTextStory).Select
     
    Selection.HomeKey
     
     
    R1 = i
    R3 = j
     
            'remove highlighting if defined just once
     
    If i > 0 And j > 0 Then
    
    ElseIf i <= 1 And j = 0 Then
    oRng.HighlightColorIndex = wdNone
    ElseIf i = 0 And j <= 1 Then
    oRng2.HighlightColorIndex = wdNone
    Else
    End If
       
        End With
    End With
     
    i = 0
    j = 0
     
            'C. go back to last term
     
      myRange.Select
       
        Selection.MoveLeft unit:=wdCharacter, Count:=1
     
     
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^0147"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
     
     
        Selection.MoveRight unit:=wdCharacter, Count:=1
        Selection.Extend
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "^0148"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
     
     
        Selection.MoveLeft unit:=wdCharacter, Count:=1
       
     
         Selection.ExtendMode = False
        
     
    StrFind = Selection.Text
    StrReplace = Selection.Text
     
     
            'shorten selection by one character to handle plurals
     
        If Len(StrReplace) > 3 Then
            Length = Len(StrReplace) - 1
        Else
            Length = Len(StrReplace)
        End If
     
    StrFind2 = Mid$(StrReplace, 1, Length)
    StrReplace2 = Mid$(StrReplace, 1, Length)
     
      Set myRange = Selection.Range
     
     
    With Selection
        .HomeKey wdStory
       
     
            'highlight all copies yellow
     
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdYellow
                i = i + 1
                ActiveDocument.UndoClear
            Loop
           
    If ActiveDocument.Footnotes.Count >= 1 Then
     
           
                ActiveDocument.StoryRanges(wdFootnotesStory).Select
               
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdYellow
                i = i + 1
                ActiveDocument.UndoClear
            Loop
    End If
     
    ActiveDocument.StoryRanges(wdMainTextStory).Select
     
    R2 = i
     
        End With
    End With
     
     
    
            'check if term defined, but not used, and highlight red
     
    If R2 = R1 + R3 Then
     
    With Selection
        .HomeKey wdStory
     
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdRed
                i = i + 1
                ActiveDocument.UndoClear
            Loop
           
    If ActiveDocument.Footnotes.Count >= 1 Then
           
                ActiveDocument.StoryRanges(wdFootnotesStory).Select
               
                Selection.HomeKey
               
            Do While .Execute(FindText:=StrFind2, _
                MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) = True
                Set oRng = Selection.Range
                oRng.HighlightColorIndex = wdRed
                i = i + 1
                ActiveDocument.UndoClear
            Loop
    End If
     
     
    ActiveDocument.StoryRanges(wdMainTextStory).Select
     
    End With
    End With
     
    End If
     
      
    i = 0
    R1 = 0
    R2 = 0
     
      myRange.Select
     
       
    If myRange = Chr(147) & "xyxy" & Chr(148) _
    Or myRange = Chr(147) & "Xyxy" & Chr(148) _
    Or myRange = Chr(147) & "XYXY" & Chr(148) Then
    GoTo Skip3
    Else
    End If
     
     
        Selection.MoveRight unit:=wdCharacter, Count:=1
     
    Skip:
     
    ActiveDocument.UndoClear
     
     
    Loop
     
     
    
     
    Skip3:
    
    'FOOTNOTE LOOP
    
     
    SkipFootnote:
     
    
     
    Set oRng = Nothing
    Set oRng2 = Nothing
    StrFind = vbNullString
    StrReplace = vbNullString
    StrReplace2 = vbNullString
    StrFind2 = vbNullString
    char = vbNullString
     
     
    Call ClearFindAndReplaceParameters
     
    Skip2:
     
            'insert text box in header
     
        Selection.HomeKey unit:=wdStory
        Selection.MoveRight unit:=wdWord, Count:=3, Extend:=wdExtend
        Selection.Delete unit:=wdCharacter, Count:=1
       
        If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
            ActiveWindow.Panes(2).Close
        End If
        If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
            ActivePane.View.Type = wdOutlineView Then
            ActiveWindow.ActivePane.View.Type = wdPrintView
        End If
       
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.HeaderFooter.Shapes.AddTextbox(msoTextOrientationHorizontal, _
            99#, 28.8, 144#, 171#).Select
        Selection.ShapeRange.TextFrame.TextRange.Select
        Selection.Collapse
        Selection.TypeText Text:="cyan quotes = term defined more than once"
        Selection.TypeParagraph
        Selection.TypeText Text:="yellow = all instances of defined term"
        Selection.TypeParagraph
        Selection.TypeText Text:="red = term defined, but not used"
        Selection.TypeParagraph
        Selection.TypeText Text:="purple = possible undefined terms"
        Selection.TypeParagraph
        Selection.TypeText Text:="green = fields and selected references"
       
            Selection.WholeStory
        Selection.Font.Size = 8
        Selection.ShapeRange.Select
        Selection.ShapeRange.Fill.Visible = msoTrue
        Selection.ShapeRange.Fill.Solid
        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
        Selection.ShapeRange.Fill.Transparency = 0#
        Selection.ShapeRange.Line.Weight = 0.75
        Selection.ShapeRange.Line.DashStyle = msoLineSolid
        Selection.ShapeRange.Line.Style = msoLineSingle
        Selection.ShapeRange.Line.Transparency = 0#
        Selection.ShapeRange.Line.Visible = msoTrue
        Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
        Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.ShapeRange.Height = 53.5
        Selection.ShapeRange.Width = 215.3
        Selection.ShapeRange.Left = 99.35
        Selection.ShapeRange.Top = 28.8
        Selection.ShapeRange.TextFrame.MarginLeft = 7.2
        Selection.ShapeRange.TextFrame.MarginRight = 7.2
        Selection.ShapeRange.TextFrame.MarginTop = 1.44
        Selection.ShapeRange.TextFrame.MarginBottom = 1.44
        Selection.ShapeRange.RelativeHorizontalPosition = _
            wdRelativeHorizontalPositionColumn
        Selection.ShapeRange.RelativeVerticalPosition = _
            wdRelativeVerticalPositionParagraph
        Selection.ShapeRange.Left = InchesToPoints(0.13)
        Selection.ShapeRange.Top = InchesToPoints(-0.1)
        Selection.ShapeRange.LockAnchor = False
        Selection.ShapeRange.LayoutInCell = True
        Selection.ShapeRange.WrapFormat.AllowOverlap = True
        Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
        Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
        Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
        Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
        Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
        Selection.ShapeRange.WrapFormat.Type = 3
        Selection.ShapeRange.ZOrder 4
        Selection.ShapeRange.TextFrame.AutoSize = False
        Selection.ShapeRange.TextFrame.WordWrap = True
        Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
        Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
     
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
     
     
     
    Application.ScreenUpdating = True
     
     
     
    ActiveDocument.UndoClear
     
    Selection.Find.ClearFormatting
    Call ClearFindAndReplaceParameters
     
    Exit Sub
    Out3:
       
    
    End Sub

  9. #9
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,311
    Location
    Quote Originally Posted by freed59 View Post
    I couldn't get it to run
    Getting it to 'run' is trivial - simply add it to a VBA module then click anywhere in it and press F5 - or run it from the GUI the same as might do for most macros.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  10. #10
    VBAX Newbie
    Joined
    May 2021
    Posts
    5
    Location
    Quote Originally Posted by macropod View Post
    Getting it to 'run' is trivial - simply add it to a VBA module then click anywhere in it and press F5 - or run it from the GUI the same as might do for most macros.
    Understood, but it doesn't compile - I made some changes to get it to compile, but it nothing happens when run.

    It's OK - I'll figure something out . . .

    Thanks for your help.

  11. #11
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,311
    Location
    I tested the code before posting it and it compiled and ran just fine... Your changes - whatever they were - are unlikely to have made it more likely to do either.

    As for your own code, I don't have the time to pore over the 700+ lines you posted.

    What I can say, though, is that it's extremely inefficient, with loads of Select and Selection references, view switching, and so on, none of which is necessary.

    Some of the code also seems quite redundant. For example, having used Find/Replace to convert plain quotes to smart quotes, you then test for unmatched plain quotes. Both of those tests, by the way, have been taken from code I've posted elsewhere (e.g. https://www.msofficeforums.com/104926-post4.html)...
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •