Create & Apply Character Styles for Export to InDesign

[stky]

If the document exists the style leave else need to create the character style.

after that can create more style like this.

Sub CStyle()

    Dim objDoc As Document
    Dim cbolditalic As Style
    Set objDoc = ActiveDocument

    Set cbolditalic = ActiveDocument.Styles.Add("*italic", Type:=WdStyleType.wdStyleTypeCharacter)
    With cbolditalic.Font
        .Name = "Times New Roman"
        .Bold = False
        .italic = True
        .Subscript = False
        .Superscript = False

    End With

    Dim rngStory As Range
    For Each rngStory In ActiveDocument.StoryRanges

        Application.ScreenUpdating = False
        With ActiveDocument.Range
            With rngStory.Find

                Options.DefaultHighlightColorIndex = wdYellow
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = ""
                .Replacement.Text = ""
                .MatchWildcards = True
                .Format = True
                .Forward = True
                .Wrap = wdFindContinue

                .Font.Bold = False
                .Font.italic = True
                .Font.Subscript = False
                .Font.Superscript = False
                .Replacement.Style = "*italic"
                .Replacement.Highlight = True
                .Execute Replace:=wdReplaceAll


            End With
        End With
    Next rngStory
    Application.ScreenUpdating = True
End Sub

[macropod]

Why are you trying to create an italics Character Style when Word already comes with one (Emphasis) built-in?

It seems to me you have already asked about this at: create character style

[stky]

Need to import word files as styled word file in InDesign in some word files while import Emphasis and Strong to come properly. Kindly help me.

[macropod]

For example, the following code creates and applies a series of character Styles throughout the document.

Sub ApplyCharacterStyles()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, j As Long, ArrStyl, ArrItal, ArrBold, ArrUlin, bFnd As Boolean
ArrStyl = Array("Bold", "Italic", "Underline", "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline")
ArrBold = Array(True, False, False, True, True, False, True)
ArrItal = Array(False, True, False, True, False, True, True)
ArrUlin = Array(False, False, True, False, True, True, True)
With ActiveDocument
  For i = 0 To UBound(ArrStyl)
    For j = 1 To .Styles.Count
      bFnd = (ArrStyl(i) = .Styles(j)): If bFnd = True Then Exit For
    Next
    If bFnd = False Then .Styles.Add Name:=ArrStyl(i), Type:=wdStyleTypeCharacter
  Next
  For i = 0 To UBound(ArrStyl)
    With .Styles(ArrStyl(i)).Font
      .Italic = ArrItal(i)
      .Bold = ArrBold(i)
      .Underline = ArrUlin(i)
    End With
  Next
  For Each Rng In .StoryRanges
    For i = UBound(ArrStyl) To 0 Step -1
      With Rng.Duplicate
        With .Find
          With .Font
            .Italic = ArrItal(i)
            .Bold = ArrBold(i)
            .Underline = ArrUlin(i)
          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)
            Else
              With .Paragraphs.First.Range.Style.Font
                If .Italic <> ArrItal(i) Then
                  If .Bold <> ArrBold(i) Then
                    If .Underline <> ArrUlin(i) Then .Style = ArrStyl(i)
                  End If
                End If
              End With
            End If
          End If
          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

[stky]

Is this macro create character styles and change to the character styles

While run its stop in the line

With .Styles(ArrStyl(i)).Font

[macropod]

The code creates and applies the character Styles throughout the document.

It runs without error for me.

[Guessed]

Paul's code looks pretty slick to me and I can't see why it might be failing on your machine. Can you verify that the document is not protected and you are able to add new styles?
I did make some changes to Paul's code to remove the need for the extra arrays.

Sub ApplyCharacterStyles()
  Application.ScreenUpdating = False
  Dim Rng As Range, i As Long, j As Long, ArrStyl, ArrItal, ArrBold, ArrUlin, bFnd As Boolean, aSty As Style
  ArrStyl = Array("Bold", "Italic", "Underline", "Bold Italic", "Bold Underline", "Italic Underline", "Bold Italic Underline")

  With ActiveDocument
    On Error Resume Next
      For i = 0 To UBound(ArrStyl)
        Set aSty = .Styles(ArrStyl(i))
        If aSty Is Nothing Then
          Set aSty = .Styles.Add(Name:=ArrStyl(i), Type:=wdStyleTypeCharacter)
        End If
        With aSty.Font
          .Italic = aSty.NameLocal Like "*Italic*"
          .Bold = aSty.NameLocal Like "*Bold*"
          .Underline = aSty.NameLocal Like "*Underline*"
        End With
        Set aSty = Nothing
      Next
    On Error GoTo 0

    For Each Rng In .StoryRanges
      For i = UBound(ArrStyl) To 0 Step -1
        Set aSty = ActiveDocument.Styles(ArrStyl(i))
        With Rng.Duplicate
          With .Find
            With .Font
              .Italic = aSty.Font.Italic
              .Bold = aSty.Font.Bold
              .Underline = aSty.Font.Underline
            End With
          End With
          Do While .Find.Execute = True
            If .Style <> aSty Then
              If .Start <> .Paragraphs.First.Range.Start Or .End <> .Paragraphs.Last.Range.End Then
                .Style = ArrStyl(i)
              Else
                With .Paragraphs.First.Range.Style.Font
                  If .Italic <> aSty.Font.Italic Then
                    If .Bold <> aSty.Font.Bold Then
                      If .Underline <> aSty.Font.Underline Then .Style = aSty
                    End If
                  End If
                End With
              End If
            End If
            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

[stky]

But it replace only in Tables.

Not replacing in stories.

I have attached the Test_Sample file too.

Sorry for the trouble better can we add highlight while replace.

For the changed done in those areas.

[macropod]

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.

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.

[stky]

Thanks you very much Paul Edstein (macropod) and Andrew Lockton (Guessed)