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

Comments

Post a Comment

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds " " in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box. Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement. Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait ( Seconds As Double ) ''non cpu-intensive wait timer '' https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start () Dim Time As Date Dim Count As ...
Read more

Revit area plans adding new types and references (Gross and rentable)

Image
Note to self: Add additional (duplicate) gross area and net area schemed under Area Plans And Area schemes... Really counter-intuitive place to put this instead of say...  Area Plans> New Type> Edit Type (ADD) or Create an area plan, then Go to Properties, Edit Type and Duplicate... Always seem to forget this one! 2015-10-16-And for the calculation type... To update: this also applies to Revit as well as LT- The gross calculations cannot be overridden, however the 'rentable' comes in various flavors... From AD Revit help: Applies to Revit LT 2015 Rules are determined by one type of space bordering another space. The following table shows area measurement rules. To find the appropriate measurement rule, find the selected Area Type and the corresponding Bordering Area Type. Gross Building Area Scheme Types Gross Building Area Scheme Types Area Type Selected Bordering Area Type Measurement Rule Gross Building Area Gross Buil...
Read more