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
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 = ""
SaveSelectionSpacing = Selection.Font.Spacing
If SaveSelectionSpacing = 0 Then
If SaveSelectionStart = SaveSelectionEnd Then
SaveDocumentSpacing = ActiveDocument.Content.Font.Spacing
End If
End If
.Position = ""
SaveSelectionPosition = Selection.Font.Position
If SaveSelectionPosition = 0 Then
If SaveSelectionStart = SaveSelectionEnd Then
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 .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
|