Sub TitlesReveal()
' Paul Beverley - Version 09.04.25
' Switches the next light grey font colour to full colour

' PB blue
myColorBlue = &HFF0000
' JY blue
myColorBlue = &HF0B000

preBlue = &HF6F6F6
preRed = &HF4F4F4
preBlack = &HF5F5F5

Set docNow = ActiveDocument
pbTitlesFile.Activate
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False

stopNow = False
doneSome = False
Set rng = Selection.Range.Duplicate
rng.Expand wdParagraph
rng.Collapse wdCollapseStart
Do While stopNow = False And doneSome = False
  Do
    rng.Collapse wdCollapseEnd
    rng.Expand wdParagraph
    ln = Len(rng)
    DoEvents
    Debug.Print rng.Start, ActiveDocument.Content.End
    If ActiveDocument.Content.End - rng.Start < 3 Then
      Beep
      Exit Sub
    End If
    DoEvents
  Loop Until ln > 1 And Asc(rng) <> 12
  gotBox = False
  rng.Select
  Selection.Collapse wdCollapseStart
  
  For Each wd In rng.Words
    newColor = 99
    myColour = wd.Font.Color
    If myColour = 9999999 Then
      For Each ch In wd.Characters
        myColour = ch.Font.Color
        Select Case myColour
          Case preBlue: newColor = myColorBlue
          Case preRed: newColor = wdColorRed
          Case preBlack: newColor = wdColorBlack
        End Select
        If newColor <> 99 Then
          ch.Font.Color = newColor
          doneSome = True
        End If
      Next ch
    Else
      Select Case myColour
        Case preBlue: newColor = myColorBlue
        Case preRed: newColor = wdColorRed
        Case preBlack: newColor = wdColorBlack
      End Select
      If newColor <> 99 Then
        wd.Font.Color = newColor
        doneSome = True
      End If
    End If
    stopMiddle = (AscW(Right(wd, 1)) = 160 Or Asc(wd) = 11)
    If doneSome = True And (stopMiddle Or wd = vbCr) Then
      stopNow = True
      Exit For
    End If
  Next wd
  DoEvents
Loop
If stopMiddle Then
  wd.Select
Else
  rng.Select
End If
Selection.Collapse wdCollapseEnd
ActiveDocument.TrackRevisions = myTrack
docNow.Activate
End Sub