Word: Direct Format text

This may sound strange, but sometimes it's necessary to just direct format word text, without any styles getting in the way.

For instance, you might like to copy some text into another application, while preserving the fonts and sizes. But if you're using styles, then the actual text may change if you copy this across, as the destination application will use its underlying styles, if the character formats are unchanged from the style.

The macro below changes the currently selected paragraph into directly formatted text. It does this by adding a nonsense style called "Plain" which uses a mythical font "Plain" and a size of "1". It then changes the paragraph style to "Plain". And then it reapplies the font to each character in turn. Because each character format is now different from the nonsense style, Word is forced to directly format each character directly.

Now it shouldn't matter which application you now copy and paste the text - it will maintain the font and the size no matter what.

Sub DirectFormatSelectedParagraph()

' https://answers.microsoft.com/en-us/msoffice/forum/all/macro-to-apply-style-without-overriding-direct/2dbadb6b-f6b4-44de-9b5a-83c3a7a7e651

' Macro created by Stefan Blom, MVP, October 2018

' In the first paragraph in the selection, store font settings in

' an array, apply the style of your choice, and then reapply the

' font formatting.

'

' Modified by Edward Chan to make it always work, by adding

' .duplicate to the font

' Also added a style called "Plain" to force the font to be directly formatted.

'

    Dim x()         As Font

    Dim counter     As Long

    Dim j           As Long

    Dim m           As Long

    Call CreatePlainStyle ' Create a plain style first, to force all direct formatting

    counter = Selection.Paragraphs(1).Range.Characters.Count - 1

    For j = 1 To counter

        ReDim Preserve x(1 To counter)

        Set x(j) = Selection.Paragraphs(1).Range.Characters(j).Font.Duplicate

    Next j

    Selection.Paragraphs(1).Style = "Plain"  ' A new style without font or size

    For m = 1 To counter

        Selection.Paragraphs(1).Range.Characters(m).Font = x(m)

    Next m

End Sub

Sub CreatePlainStyle()

'

' Create a new style where the font is called "plain" to force the

' font to be manually set for each character

'

    On Error Resume Next

    ActiveDocument.Styles.Add Name:="Plain", Type:=wdStyleTypeParagraph

    On Error GoTo 0

    ActiveDocument.Styles("Plain").AutomaticallyUpdate = False

    With ActiveDocument.Styles("Plain").Font

        .Name = "Plain"

        .Size = 1

        .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 = 1

        .Animation = wdAnimationNone

        .Ligatures = wdLigaturesStandardContextual

        .NumberSpacing = wdNumberSpacingDefault

        .NumberForm = wdNumberFormDefault

        .StylisticSet = wdStylisticSetDefault

        .ContextualAlternates = 0

    End With

    With ActiveDocument.Styles("Plain").ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)

        .RightIndent = CentimetersToPoints(0)

        .SpaceBefore = 0

        .SpaceBeforeAuto = False

        .SpaceAfter = 10

        .SpaceAfterAuto = False

        .LineSpacingRule = wdLineSpaceMultiple

        .LineSpacing = LinesToPoints(1.15)

        .Alignment = wdAlignParagraphLeft

        .WidowControl = True

        .KeepWithNext = False

        .KeepTogether = False

        .PageBreakBefore = False

        .NoLineNumber = False

        .Hyphenation = True

        .FirstLineIndent = CentimetersToPoints(0)

        .OutlineLevel = wdOutlineLevelBodyText

        .CharacterUnitLeftIndent = 0

        .CharacterUnitRightIndent = 0

        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 0

        .LineUnitAfter = 0

        .MirrorIndents = False

        .TextboxTightWrap = wdTightNone

        .CollapsedByDefault = False

    End With

    ActiveDocument.Styles("Plain").NoSpaceBetweenParagraphsOfSameStyle = False

    ActiveDocument.Styles("Plain").ParagraphFormat.TabStops.ClearAll

    With ActiveDocument.Styles("Plain").ParagraphFormat

        With .Shading

            .Texture = wdTextureNone

            .ForegroundPatternColor = wdColorAutomatic

            .BackgroundPatternColor = wdColorAutomatic

        End With

        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone

        .Borders(wdBorderRight).LineStyle = wdLineStyleNone

        .Borders(wdBorderTop).LineStyle = wdLineStyleNone

        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone

        With .Borders

            .DistanceFromTop = 1

            .DistanceFromLeft = 4

            .DistanceFromBottom = 1

            .DistanceFromRight = 4

            .Shadow = False

        End With

    End With

    ActiveDocument.Styles("Plain").Frame.Delete

End Sub