Macro for heading capitalization

Question

Hi, I'm wondering if someone can help me with the following macro for setting the capitalization in headings.

Here are the parameters:

1. There are three possible paragraph styles for the headings.
2. Each heading is preceded by a four-character typesetting code that should be left alone.
3. The headings should be set in sentence style, meaning everything is lowercase except the first letter of the heading and the first letter after a colon, question mark, or exclamation point. Sometimes an opening quotation mark precedes the first letter or the letter after a colon, etc.
4. Any proper nouns or acronyms that appear in the heading should be capped; I mark them ahead of time in turquoise highlighting.

I think the basic structure of the macro below should work, but I'm at a loss as to how to approach the coding in the Do While part. Your help would be greatly appreciated.

Sub HeadingCap()

Dim StrStyles As String, i As Long

StrStyles = "HedStyle1|HedStyle2|HedStyle3"

For i = 0 to UBound(Split(StrStyles, "|"))

With ActiveDocument.Content

With .Find

  .Style = Split(StrStyles, "|")(i)

  .Format = True

  .Wrap = wdFindStop

  .Forward = True

  .Text = ""

  .Execute

End With

Do While .Find.Found

  'exclude typesetting code

   .MoveStart Unit:=wdCharacter, Count:=4 

  'lc everything

  .Case = wdLowerCase

  'cap first letter

  If (.Characters.First = Chr(147)) = True Then

    .Characters(2).Case = wdTitleWord

  Else

   .Characters.First.Case = wdTitleWord

  End If

   strLength = .Characters.Count

   For j = 1 To strLength

         'I realize the following coding is wrong; _

          I'm just trying to show what needs to happen 

         'cap letter after colon, q mark, or excl. pnt. plus opening qt.

         If .Characters(j) = "[:?!] ^0147" Then

             .Characters(j + 1).Case = wdTitleWord

         'cap letter after colon, q mark, or excl. pnt.

         ElseIf .Characters(j) = "[:?!] [a-z]" Then

             .Characters.Last.Case = wdTitleWord

         End If

         'cap, then unhighlight turq letters

         If (.Characters(j).HighlightColorIndex = wdTurquoise) = True Then

           .Characters(j).Case = wdUpperCase

           .Characters(j).HighlightColorIndex = wdNoHighlight

         End If

   Next j

   .Collapse wdCollapseEnd

   .Find.Execute

Loop

End With

Next i

End Sub

Answer 1

Ok.

That helps.

First up, remember that the No-width break is not a space--it has no width, and so should not cause problems, although if the document is converted to another format in the typesetting, it's anyone's guess whether the non-width break will be converted correctly.

Second, the big deal isn't really a big deal at all. It's just what I would consider, if I were doing this, to be best practice. Certainly it would have simplified the macro quite a bit.

Third, I think (but I'm guessing) that your mixed results with the capitilization after Chr(147) comes from a mixture of smart and straight quotes in your document. See how I corrected for that below. And seeing as we are targeting a single character there, why let Word guess what it should be? So I changed wdTitleWord to wdUppercase.

Then, your strings for .Characters(j) = ": " & Chr147 [etc.] didn't work because you are comparing a 1-character string [.Characters(j)] to a 2-character string [": "]. The result will always be false.

Fifth, the multiple if statements just complicate matters, so I just conflated all of it into one comparison with Like.

I still think the macro below as I modified it is terribly inefficient, but it does the job on the samples you provided.

Let me know if it works for you.

Sub HeadingCap()

Dim StrStyles As String, strLength As String

Dim sQuotes As String

Dim i As Long, j As Long

StrStyles = "HedStyle1|HedStyle2|HedStyle3"

sQuotes = Chr(34) & Chr(147) 'Probably no need to add chr(148)?

For i = 0 To UBound(Split(StrStyles, "|"))

With ActiveDocument.Content

With .Find

  .Style = Split(StrStyles, "|")(i)

  .Format = True

  .Wrap = wdFindStop

  .Forward = True

  .Text = ""

  .Execute

End With

Do While .Find.Found

  'exclude typesetting code

   .MoveStart Unit:=wdCharacter, Count:=4

  'lc everything

   .Case = wdLowerCase

  'cap first letter

  .Characters(IIf(InStr(1, sQuotes, .Characters.First, vbTextCompare) > 0, 2, 1)).Case = wdUpperCase

    'cap letters after "[:?!] "

    strLength = .Characters.Count

    For j = 1 To strLength

      If .Characters(j) Like "[:?!""“]" Then _

        .Characters(j + IIf(.Characters(j + 1) Like " ", 2, 1)).Case = wdUpperCase

     'cap turq-highlighted letters

      If (.Characters(j).HighlightColorIndex = wdTurquoise) = True Then

        .Characters(j).Case = wdUpperCase

        .Characters(j).HighlightColorIndex = wdNoHighlight

      End If

    Next j

   .Collapse wdCollapseEnd

   .Find.Execute

Loop

End With

Next i

End Sub

Answer 2

Ok. That can still be done, but before I look at that, one comment, and one request:

Firstly, it's simply crazy to have the typesetting code prefixed to the first word of the heading (even if that word is sometimes in quotes). That messes up more than just the capitalization, it also affects a whole host of other things, with spell checking, cross referencing, and tables of contents coming to mind as some of the most obvious. Oh, and, of course, making tasks like this macro that much more complex.

Why not at least separate them with a no-width break? (If you don't know those, look at: Insert|Symbol|More Symbols... and then in the Special characters tab, you will find No-Width Optional Break and No-Width Non Break--I would suggest using the latter).

Have you done anything else to identify those typesetting codes as typesetting codes (e.g., made them a different colour, highlighted them in some way, made them hidden text--which would be my choice)?

Ok, now that I have that off my chest, can you at least post a few of these headings so that we can just get a clearer idea of what they look like? That would really help.

Answer 3

Hi Jacques,

Thanks for your input. There is no space after the typesetting code, so 4 is correct. I tried wdSentenceCase, as you suggested, but the result was that everything was lowercased, as with wdLowerCase.

I agree that I could split the macro into a few pieces to make all the changes, but I really want to understand how to do this

as efficiently as possible, all in one Do While block. I've had another go at it, but still no luck:

Sub HeadingCap()

Dim StrStyles As String, strLength As String

Dim i As Long, j As Long

StrStyles = "HedStyle1|HedStyle2|HedStyle3"

For i = 0 To UBound(Split(StrStyles, "|"))

With ActiveDocument.Content

With .Find

  .Style = Split(StrStyles, "|")(i)

  .Format = True

  .Wrap = wdFindStop

  .Forward = True

  .Text = ""

  .Execute

End With

Do While .Find.Found

  'exclude typesetting code

   .MoveStart Unit:=wdCharacter, Count:=4

  'lc everything

   .Case = wdLowerCase

  'cap first letter

  'mixed results; sometimes works, sometimes doesn't

    If (.Characters.First = Chr(147)) = True Then

      .Characters(2).Case = wdTitleWord

    Else

     .Characters.First.Case = wdTitleWord

    End If

    'cap letters after "[:?!] "

    strLength = .Characters.Count

    For j = 1 To strLength

      'this works, but then ...

      If .Characters(j) = ":" Then

         .Characters(j + 2).Case = wdTitleWord

      ElseIf .Characters(j) = "?" Then

      'error on the next line: _

       Requested Member of the Collection Does Not Exist

        .Characters(j + 2).Case = wdTitleWord

      ElseIf .Characters(j) = "!" Then

         .Characters(j + 2).Case = wdTitleWord

      End If

      'Cap letters after "[:?!] ^0147"

      'No error here, but it doesn't work

      If .Characters(j) = ": " & Chr147 Then

         .Characters(j + 1).Case = wdTitleWord

      ElseIf .Characters(j) = "? " & Chr147 Then

         .Characters(j + 1).Case = wdTitleWord

      ElseIf .Characters(j) = "! " & Chr147 Then

         .Characters(j + 1).Case = wdTitleWord

      End If

     'cap turq-highlighted letters 

     'this works

      If (.Characters(j).HighlightColorIndex = wdTurquoise) = True Then

        .Characters(j).Case = wdUpperCase

        .Characters(j).HighlightColorIndex = wdNoHighlight

      End If

    Next j

   .Collapse wdCollapseEnd

   .Find.Execute

Loop

End With

Next i

End Sub

Answer 4

Is there a space between the typesetting code and the heading?

If so, and the code is 4 characters, shouldn't it be 

.MoveStart Unit:=wdCharacter, Count:=5

instead of

.MoveStart Unit:=wdCharacter, Count:=4

I would also consider changing 

.Characters.First.Case = wdTitleWord

to

.Words.First.Case = wdTitleWord

Next, why not let Word do the heavy lifting and instead of:

  'lc everything

  .Case = wdLowerCase

do this:

  'Title case everything

   .Case = wdTitleSentence

Then, all you would have to do is complete the 

'Cap first letter

...

section, as the Title case would not work if the typesetting code precedes a word in inverted commas.

Lastly, I would suggest cutting the whole bit of code from strLength to Next J and rather doing this:

Do all the loops making all your headings title case.

Then repeat a similar find searching for the turquoise highlighted text, and making that all caps.

So you would be doing something like this:

Sub NewHeadingCap()

    Dim StrStyles As String, i As Long

   StrStyles = "HedStyle1|HedStyle2|HedStyle3"

    With ActiveDocument.Content

        For i = 0 To UBound(Split(StrStyles, "|"))

            With .Find

              .Style = Split(StrStyles, "|")(i)

              .Format = True

              .Wrap = wdFindStop

              .Forward = True

              .Text = ""

              .Execute

            End With

            Do While .Find.Found

              'exclude typesetting code

               .MoveStart Unit:=wdCharacter, Count:=5

              'Titlecase everything

               .Case = wdTitleSentence

              'cap first letter

              .Words.First.Case = wdTitleWord

              If (.Characters.First = Chr(147)) = True Then

                .Characters(2).Case = wdTitleWord

              Else

               .Characters.First.Case = wdTitleWord

              End If

               .Collapse wdCollapseEnd

               .Find.Execute

            Loop

        Next i

    End With

    With ActiveDocument.Content

        With .Find

          .ClearFormatting

          .Highlight = True

          .Format = True

          .Wrap = wdFindStop

          .Forward = True

          .Text = ""

          .Execute

        End With

        Do While .Find.Found

            'cap, then unhighlight turq letters

            If .HighlightColorIndex = wdTurquoise Then

              .Case = wdUpperCase

              .HighlightColorIndex = wdNoHighlight

            End If

           .Collapse wdCollapseEnd

           .Find.Execute

        Loop

    End With

End Sub

Answer 5

It will be a lot easier to help with something like this is you can put a copy of a document in a folder on your OneDrive and set that folder to be shared and then put a link to the folder in a message that you post back here.