Create & Apply Character Styles for Export to InDesign

stky · #1 11-29-2022, 06:16 AM

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

after that can create more style like this.

Code:

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 · #2 11-29-2022, 03:38 PM

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 · #3 11-29-2022, 07:52 PM

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 · #4 11-29-2022, 10:33 PM

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

Code:

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 · #5 11-29-2022, 10:51 PM

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

While run its stop in the line

Code:

With .Styles(ArrStyl(i)).Font

macropod · #6 11-29-2022, 10:54 PM

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

It runs without error for me.

Guessed · #7 11-29-2022, 11:40 PM

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.

Code:

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 · #8 11-29-2022, 11:40 PM

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 · #9 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.

stky · #10 11-30-2022, 03:09 AM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Styles: Cannot Apply or Save	Justin	Word	5	11-01-2020 03:20 PM
Macro to apply Normal dot styles	John9210	Word VBA	2	06-07-2018 05:15 PM
Apply styles in word table	1van	Word VBA	2	11-17-2015 11:05 AM
search for special character and apply outline?	n00bie-n00b	Word VBA	0	10-12-2014 03:17 AM
automatically extract footnotes into new file and apply character format to footnote	hrdwa	Word	0	02-27-2010 03:16 AM