Microsoft Office Forums - View Single Post - [Solved] Create & Apply Character Styles for Export to InDesign

macropod · 11-30-2022, 12:34 AM

Quote:

Originally Posted by stky

But it replace only in Tables.

Not so. It replaces in all StoryRanges

Try the following, which implements some of Andrew's approach. I have confirmed that it works in the document body (including in tables), headers, footers, footnotes, and endnotes. All character Style applications will be highlighted.

Code:

Sub ApplyCharacterStyles()
Application.ScreenUpdating = False
Dim Stl As Style, Rng As Range, i As Long, j As Long, ArrStyl, bFnd As Boolean
ArrStyl = Array("Superscript", "Subscript", "Bold", "Italic", "Underline", _
          "Superscript Bold", "Superscript Italic", "Superscript Underline", _
          "Subscript Bold", "Subscript Italic", "Subscript Underline", _
          "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline", _
          "Superscript Bold Italic", "Superscript Bold Underline", "Superscript Bold Italic Underline", _
          "Subscript Bold Italic", "Subscript Bold Underline", "Subscript Bold Italic Underline")
With ActiveDocument
  On Error Resume Next
  For i = 0 To UBound(ArrStyl)
    Set Stl = .Styles(ArrStyl(i))
    If Stl Is Nothing Then Set Stl = .Styles.Add(Name:=ArrStyl(i), Type:=wdStyleTypeCharacter)
    With Stl
      .Font.Italic = .NameLocal Like "*Italic*"
      .Font.Bold = .NameLocal Like "*Bold*"
      .Font.Underline = .NameLocal Like "*Underline*"
      .Font.Superscript = .NameLocal Like "*Superscript*"
      .Font.Subscript = .NameLocal Like "*Subscript*"
    End With
    Set Stl = Nothing
  Next
  On Error GoTo 0
  For Each Rng In .StoryRanges
    For i = UBound(ArrStyl) To 0 Step -1
      Set Stl = .Styles(ArrStyl(i))
      With Rng.Duplicate
        With .Find
          With .Font
            .Italic = Stl.Font.Italic
            .Bold = Stl.Font.Bold
            .Underline = Stl.Font.Underline
            .Superscript = Stl.Font.Superscript
            .Subscript = Stl.Font.Subscript
          End With
        End With
        Do While .Find.Execute = True
          If .Style <> ArrStyl(i) Then
            If .Start <> .Paragraphs.First.Range.Start Or .End <> .Paragraphs.Last.Range.End Then
              .Style = ArrStyl(i): .HighlightColorIndex = wdYellow
            Else
              bFnd = False
              With .Paragraphs.First.Range.Style.Font
                If .Italic <> Stl.Font.Italic Then
                  If .Bold <> Stl.Font.Bold Then
                    If .Underline <> Stl.Font.Underline Then
                      If .Superscript <> Stl.Font.Superscript Then
                        If .Subscript <> Stl.Font.Subscript Then
                          .Style = Stl: bFnd = True
                        End If
                      End If
                    End If
                  End If
                End If
              End With
            End If
          End If
          If bFnd = True Then .Paragraphs.First.Range.HighlightColorIndex = wdYellow
          If .Information(wdWithInTable) = True Then
            If .End = .Cells(1).Range.End - 1 Then .Start = .Cells(1).Range.End
            If .Information(wdAtEndOfRowMarker) = True Then .Start = .End + 1
          End If
          If .End = Rng.End Then Exit Do
          .Collapse wdCollapseEnd
        Loop
      End With
    Next
  Next
End With
Application.ScreenUpdating = True
MsgBox "Finished applying Character Styles"
End Sub

A couple of caveats:
• No attempt is made to manage hard formatting that's been applied to a whole paragraph to make it look like a paragraph for which a different Paragraph Style exists.
• No attempt is made to manage hard formatting within a paragraph that changes font sizes, colours, etc. with or without italics, etc.
In such cases, you may end up with the font size, colour, etc. changing as a result of the application of the Character Styles. There's only so much undisciplined formatting one can reasonably manage programmatically; wrist-slapping is in order for anything else...

PS: Thanks Andrew for the more efficient way of verifying a Style's existence and applying the font characteristics.