Word VBA for modifying +Body and +Header (default fonts) and setting default styles

Attribute VB_Name = "Styles" Option Compare Text Const FontFixedWidth = "Courier New" ''set preferred fixed width font Const FontProportionalWidth = "Arial" ''Set preferred variable width font Sub STYLE_PURGE() Dim oStyle As Style For Each oStyle In ActiveDocument.Styles 'Only check out non-built-in styles If oStyle.BuiltIn = False Then With ActiveDocument.Content.Find .ClearFormatting .Style = oStyle.NameLocal .Execute Findtext:="", Format:=True If .Found = False Then oStyle.Delete End With End If Next oStyle End Sub Sub STYLE_Emphasize_references() ' Emphasize_See_references Macro ' Dim ShowFieldCodesStatus As Boolean ShowFieldCodesStatus = ActiveWindow.View.ShowFieldCodes ActiveWindow.View.ShowFieldCodes = True Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles( _ "Subtle Reference") With Selection.Find .Text = "^19 REF" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ActiveWindow.View.ShowFieldCodes = ShowFieldCodesStatus End Sub Sub STYLE_Headings_update() ' ' update styles with find/replace to get listed set to current document standards ' ' Application.DisplayAlerts = wdAlertsNone Dim nStyle ''As String ''Dim stylelist '' As String ''stylelist = Array("Heading 1", "Heading 2", "Heading 3", "Heading 4", "Heading 5", "Heading 6", "Normal", "Normal.Bullet") For Each nStyle In ActiveDocument.Styles Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(nStyle) Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles(nStyle) With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindAsk .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next nStyle Application.DisplayAlerts = wdAlertsAll End Sub Private Sub Set_All_font_Styles() Dim sty As Word.Style If MsgBox("This will reset ALL fonts to arial including fixed width fonts +Body and +Header styles. Continue?", vbCritical + vbYesNo, "Warning") <> vbYes Then MsgBox "Nothing done, exiting,", vbOKOnly + vbInformation, "Exiting" Exit Sub End If Dim f As ThemeFont ''MAJOR/MINOR CORE FONTS For Each f In ActiveDocument.DocumentTheme.ThemeFontScheme.MajorFont If f.Name <> "" Then f.Name = FontProportionalWidth Next f For Each f In ActiveDocument.DocumentTheme.ThemeFontScheme.MinorFont If f.Name <> "" Then f.Name = FontProportionalWidth Stop Next f For Each sty In ActiveDocument.Styles 'If sty.InUse And sty.Type = wDocStyleTypeParagraph Then If Not sty.Font.Name Like "*" & FontProportionalWidth & "*" _ And Not sty.Font.Name Like "*" & FontFixedWidth & "*" Then Debug.Print sty.NameLocal sty.Font.Name = FontProportionalWidth 'Stop End If 'sty.Font.Name = "Arial" 'End If Next End Sub Private Sub set_base_styles() 'Check for stubborn styles and defer everything (worth considering) to the ''Styles as indicated in teh if/else Dim DocStyle As Style ''Document styles Dim plusStyle As String ''+Body or +Head styles Dim DSName As String ''Doc Style Name for multi check Dim f As ThemeFont ''TOP-LEVEL GLOBAL FONT STYLES On Error GoTo 0 ''stop cold on error debugging If MsgBox("This will reset document base and font styles to " _ & FontProportionalWidth _ & " & " _ & FontFixedWidth _ & "." _ & vbCr _ & vbCr _ & "Continue?" & vbCr, vbinfo + vbYesNo, "Warning") <> vbYes Then Exit Sub End If ''MAJOR/MINOR CORE FONTS For Each f In ActiveDocument.DocumentTheme.ThemeFontScheme.MajorFont If f.Name <> "" Then f.Name = FontProportionalWidth Next f For Each f In ActiveDocument.DocumentTheme.ThemeFontScheme.MinorFont If f.Name <> "" Then f.Name = FontProportionalWidth Next f ''DOCUMENT STYLES RELATE BACK TO CORE TOP-LOEVEL FONT STYLES For Each DocStyle In ActiveDocument.Styles ''Iterate styles With DocStyle ''UseDocStyle DSName = "": DSName = DocStyle.NameLocal ''Clear then set name ''Use base style name to determine driver of fonts ''no select case for using "Like" operator so if/else/elif If DSName Like "*code*" Then ''For CODE hardcode times new fixed widht plusStyle = FontFixedWidth ElseIf DSName Like "*head*" Then plusStyle = "+Headings" Else plusStyle = "+Body" End If ''GoTo skipset ''<<<<<<<<<<<<<<<DEBUG .Font.Name = plusStyle 'With .Font 'ActiveDocument.Styles(DocStyle.NameLocal).Font.Name = plusStyle '.Size = 11 '.Bold = False '.Italic = False '.Underline = wdUnderlineNone '.UnderlineColor = wdColorAutomatic '.StrikeThrough = False '.DoubleStrikeThrough = False '.Outline = False '.Emboss = False '.Shadow = False '.Hidden = False '.SmallCaps = False '.AllCaps = False '.Color = wdColorAutomatic '.Engrave = False '.Superscript = False '.Subscript = False '.Scaling = 100 '.Kerning = 0 '.Animation = wdAnimationNone '.Ligature s = wdLigaturesNone '.NumberSpacing = wdNumberSpacingDefault '.NumberForm = wdNumberFormDefault '.StylisticSet = wdStylisticSetDefault '.ContextualAlternates = 0 'End With .UnhideWhenUsed = True ''show in style gallery when used. skipset: ''Skip setting fonts (DEBUGGING) End With Next DocStyle End Sub Sub STYLE_reset_overrides_to_style() ''override independent text overrides with style formatting. ''Selection.ClearCharacterStyle unfortunately ALSO clears character styles along with independent formatting. ''Maybe look for all non-paragraph styles to add to selection adn apply char styles? ' https://www.msofficeforums.com/word-vba/47165-macro-select-headings-all-styles.html 'Adapted to select ranges and pleace styles. Dim oParas As Paragraph ''selected paragraphs Dim oChar As Characters ''selection characters???<-----break and debug if char styles need to eb separate... Dim oStyle As Style ''styles to find/replace 'Application.ScreenUpdating = False ActiveDocument.DeleteAllEditableRanges wdEditorEveryone Selection.WholeStory Selection.ClearCharacterDirectFormatting ''clear direct formatting. Styles intact. For Each oStyle In ActiveDocument.Styles If oStyle.InUse And oStyle.Description Like "*indent:*" Then For Each oParas In ActiveDocument.Paragraphs If oParas.Style = oStyle Then oParas.Range.Editors.Add wdEditorEveryone End If Next ActiveDocument.SelectAllEditableRanges wdEditorEveryone If Not Selection Is Nothing Then ''Find Replace active selection of selected Selection.Find.ClearFormatting Selection.Find.Style = oStyle Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = oStyle With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ActiveDocument.SelectAllEditableRanges wdEditorEveryone If Selection.Style Like "*indent:*" Then Selection.ClearCharacterStyle ''https://learn.microsoft.com/en-us/office/vba/api/word.selection.clearcharacterstyle ActiveDocument.DeleteAllEditableRanges wdEditorEveryone End If End If Next oStyle 'Application.ScreenUpdating = True End Sub