Microsoft Office Forums - View Single Post - Macro that formats (true title) case by Heading style

gmaxey · 09-20-2015, 09:32 AM

Marrick,

Next time if it is a completion, I'll try harder ;-). If you are going to adapt the time saving methods incorporated by Paul then don't crap it up with another loop through the paragraphs.

Try:

Code:

Option Explicit
Sub Apply_True_Title_Case_by_Style()
Const strLCList As String = " a an and as at but by for from if in is of on or the this to "
Dim strStyleName As String
Dim oRng As Range
Dim lngIndex As Long, lngStyleCount As Long
  strStyleName = "Heading 1"
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Wrap = wdFindStop
    .Forward = True
    .Format = True
    .MatchWildcards = False
    .Text = ""
    .Style = ActiveDocument.Styles(strStyleName)
    Do While .Execute
      lngStyleCount = lngStyleCount + 1
      If oRng.End = ActiveDocument.Range.End Then Exit Do
      oRng.Collapse wdCollapseEnd
    Loop
  End With
  Select Case lngStyleCount
    Case 0:
      MsgBox "There are no occurrences of  "" & strStyleName & "" style in this document.", _
              vbInformation + vbOKOnly, "Style Count"
      Exit Sub
    Case 1
      If MsgBox("There is 1 occurrence of  " & Chr(34) + strStyleName + Chr(34) & " style in this document." & vbCr & vbCr _
              & "Do you want to apply true title case to it?", vbQuestion + vbYesNo, "Style Count") = vbNo Then
       Exit Sub
      End If
    Case Else
      If MsgBox("There are " & lngStyleCount & " occurrences of  " & Chr(34) + strStyleName + Chr(34) & _
                " style in this document." & vbCr & vbCr _
              & "Do you want to apply true title case to them?", vbQuestion + vbYesNo, "Style Count") = vbNo Then
        Exit Sub
      End If
  End Select
  Application.ScreenUpdating = False
  Set oRng = ActiveDocument.Range
  With oRng
    With .Find
      .ClearFormatting
      .Wrap = wdFindStop
      .Forward = True
      .Format = True
      .MatchWildcards = False
      .Text = ""
      .Style = ActiveDocument.Styles(strStyleName)
    End With
    Do While .Find.Execute
      With .Duplicate
        .Case = wdTitleWord
        For lngIndex = 2 To .ComputeStatistics(wdStatisticWords)
          If InStr(strLCList, " " & LCase(Trim(.Words(lngIndex))) & " ") > 0 Then
            .Words(lngIndex).Case = wdLowerCase
          End If
        Next lngIndex
      End With
      If .End = ActiveDocument.Range.End Then Exit Do
      .Collapse Direction:=wdCollapseEnd
    Loop
  End With
  Application.ScreenUpdating = True
  Select Case lngStyleCount
    Case 1
      MsgBox "Macro applied true title case to 1 instance of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results"
    Case Is > 1
      MsgBox "Macro applied true title case to " & lngStyleCount & " instances of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results"
  End Select
lbl_Exit:
  Exit Sub
End Sub