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
|