Word

Apply Formatting to Quoted Strings in a Document

Ease of Use

Intermediate

Version tested with

2003 & 97 

Submitted by:

TonyJollans

Description:

Allow a user to apply a consistent set of (Font) formatting (selected via a standard Format Dialog) to all quoted strings within either a selection or the entire document. It works with single and double quotes, smart and non-smart. 

Discussion:

In an ideal world, Character Styles (and Styles in general) would be properly used by all Word Users to apply consistent formatting throughout a Document. In the real world, that doesn't always happen so this will allow Users to quickly apply consistent formatting to quoted text throughout an existing, unstyled or partly styled, Document. Although written to work on quoted strings, delimited by any of four types of quotes, it would be relatively simple to change it to work on strings of text delimited by any character strings a User cared to choose. 

Code:

instructions for use

			

Option Explicit Sub FormatQuotedStrings() Dim Delimiter(3, 1) As String Dim d As Long Dim SaveSelectionStart As Long Dim SaveSelectionEnd As Long Dim SaveSelectionSpacing As Double Dim SaveSelectionPosition As Double Dim SaveDocumentSpacing As Double Dim SaveDocumentPosition As Double Delimiter(0, 0) = """": Delimiter(0, 1) = """" Delimiter(1, 0) = "'": Delimiter(1, 1) = "'" Delimiter(2, 0) = ChrW(8220): Delimiter(2, 1) = ChrW(8221) Delimiter(3, 0) = ChrW(8216): Delimiter(3, 1) = ChrW(8217) SaveSelectionStart = Selection.Start SaveSelectionEnd = Selection.End With Selection.Find .MatchCase = False .MatchWholeWord = False .MatchAllWordForms = False .MatchSoundsLike = False .Forward = True .Wrap = wdFindStop .ClearFormatting .Replacement.ClearFormatting .Format = True .MatchWildcards = True .Replacement.Text = "" End With ' Dialog 118 - EditReplaceFont - would be better were it available With Application.Dialogs(wdDialogFormatFont) .Tab = 0 .Font = "" .Bold = -1 .Italic = -1 .Points = "" .StrikeThrough = -1 .DoubleStrikeThrough = -1 .Superscript = -1 .Subscript = -1 .Shadow = -1 .Outline = -1 .Emboss = -1 .Engrave = -1 .SmallCaps = -1 .AllCaps = -1 .Hidden = -1 .Scale = "" .Kerning = -1 .Animations = -1 ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ' * ' Spacing (also Position) is represented by 1 Property and 2 Controls * ' Setting the property to "" makes the spinner control blank, ... * ' .. but the combo isn't controllable from code and reflects the Selection. * ' On return, the property is a number of points, if explicitly set by the User * ' .. or blank, if not set, EXCEPT when the combo is "Normal". * ' When "Normal", the return value is "0 pt" whether set by the User or not. * ' This doesn't matter if working on a non-empty Selection because the only way * ' .. it will be zero, if not set by the User, is when it was all zero anyway. * ' But when the Selection is an Insertion Point, we are working on the whole * ' .. document, and if the document contains a mixture of settings but the * ' .. value at the insertion point is zero, then we cannot tell if a returned * ' .. zero represents a default zero or an explicit User request. * ' To minimise the impact, some information is saved. See later notes on its use. * ' * ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * .Spacing = "" SaveSelectionSpacing = Selection.Font.Spacing If SaveSelectionSpacing = 0 Then ' Display will be "Normal" If SaveSelectionStart = SaveSelectionEnd Then ' Selection is collapsed SaveDocumentSpacing = ActiveDocument.Content.Font.Spacing End If End If .Position = "" SaveSelectionPosition = Selection.Font.Position If SaveSelectionPosition = 0 Then ' Display will be "Normal" If SaveSelectionStart = SaveSelectionEnd Then ' Selection is collapsed SaveDocumentPosition = ActiveDocument.Content.Font.Position End If End If If .Display = 0 Then Exit Sub Selection.Find.Replacement.Font.Name = .Font If .Bold <> -1 Then Select Case True Case .Bold = 1 And .Italic = 1 Selection.Find.Replacement.Font.Bold = True Selection.Find.Replacement.Font.Italic = True Case .Bold = 1 And .Italic = 0 Selection.Find.Replacement.Font.Bold = True Case .Bold = 0 And .Italic = 1 Selection.Find.Replacement.Font.Italic = True Case .Bold = 0 And .Italic = 0 Selection.Find.Replacement.Font.Bold = False Selection.Find.Replacement.Font.Italic = False End Select End If If .Points <> "" Then Selection.Find.Replacement.Font.Size = .Points If .StrikeThrough <> -1 Then Selection.Find.Replacement.Font.StrikeThrough = .StrikeThrough If .DoubleStrikeThrough <> -1 Then Selection.Find.Replacement.Font.DoubleStrikeThrough = .DoubleStrikeThrough If .Superscript <> -1 Then Selection.Find.Replacement.Font.Superscript = .Superscript If .Subscript <> -1 Then Selection.Find.Replacement.Font.Subscript = .Subscript If .Shadow <> -1 Then Selection.Find.Replacement.Font.Shadow = .Shadow If .Outline <> -1 Then Selection.Find.Replacement.Font.Outline = .Outline If .Emboss <> -1 Then Selection.Find.Replacement.Font.Emboss = .Emboss If .Engrave <> -1 Then Selection.Find.Replacement.Font.Engrave = .Engrave If .SmallCaps <> -1 Then Selection.Find.Replacement.Font.SmallCaps = .SmallCaps If .AllCaps <> -1 Then Selection.Find.Replacement.Font.AllCaps = .AllCaps If .Hidden <> -1 Then Selection.Find.Replacement.Font.Hidden = .Hidden If .Scale <> "" Then Selection.Find.Replacement.Font.Scaling = .Scale If .Spacing <> "" Then Selection.Find.Replacement.Font.Spacing = Val(.Spacing) If .Position <> "" Then Selection.Find.Replacement.Font.Position = Val(.Position) If .Kerning <> -1 Then Selection.Find.Replacement.Font.Kerning = .KerningMin If .Animations <> -1 Then Selection.Find.Replacement.Font.Animation = .Animations ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ' * ' IF "0 pt" is returned, AND would also have been defaulted * ' AND the selection was collapsed, AND the document has mixed settings * ' THEN we are going to ASSUME the value represents User input * ' This will give incorrect results if any of the text within quotes was set to * ' .. other than "Normal", while the setting at the insertion point was Normal. * ' If this causes a problem, a Msgbox prompt could be added to the code * ' * ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * If .Spacing = "0 pt" And SaveSelectionSpacing = 0 Then If SaveSelectionStart = SaveSelectionEnd Then If SaveDocumentSpacing = 9999999 Then Selection.Find.Replacement.Font.Spacing = 0 End If End If Else If .Spacing <> "" Then Selection.Find.Replacement.Font.Spacing = Val(.Spacing) End If If .Position = "0 pt" And SaveSelectionPosition = 0 Then If SaveSelectionStart = SaveSelectionEnd Then If SaveDocumentPosition = 9999999 Then Selection.Find.Replacement.Font.Position = 0 End If End If Else If .Position <> "" Then Selection.Find.Replacement.Font.Position = Val(.Position) End If End With Application.ScreenUpdating = False For d = LBound(Delimiter, 1) To UBound(Delimiter, 1) With Selection.Find If SaveSelectionStart = SaveSelectionEnd Then Selection.HomeKey Unit:=wdStory Else ActiveDocument.Range(SaveSelectionStart, SaveSelectionEnd).Select End If .Text = Delimiter(d, 0) & "*" & Delimiter(d, 1) .Execute Replace:=wdReplaceAll End With Next Application.ScreenUpdating = True End Sub

How to use:

  1. In Word, press Alt+F11 to Open the VBE
  2. In the Project Explorer, right click the Document or Template where you want the code
  3. Select Insert > Module
  4. Delete "Option Explicit" if it appears in the code window
  5. Cut and Paste the code here to the code window in the VBE
  6. Save the Document (or Template)
  7. Press Alt+F4 (or equivalent) to close the VBE
  8. Back in Word, press Alt+F8 to bring up the Macros Dialog
  9. Double click on FormatQuotedStrings in the list, to run it
  10. For repeated use assign a shortcut key or toolbar icon.
 

Test the code:

  1. See "How to use" or ...
  2. Download the sample which contains some notes and has the macro already assigned to a hotkey
 

Sample File:

FormatQuotedText Sample.zip 19.33KB 

Approved by mdmackillop


This entry has been viewed 91 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express