|
|
Thread Tools | Display Modes |
#16
|
|||
|
|||
I have a new challenge: how do I handle the case where someone has used track changes to delete a single space, but I need the output to clearly indicate what was done?
Example: Given the input: rasp-berry where a person editing a document has tried to delete the unwanted space between "rasp" and "berry" with track changes on, how do I get the output r̶a̶s̶p̶ ̶b̶e̶r̶r̶y̶ raspberry rather than the unwanted rasp-berry (a single-space strikethrough that is indistinguishable from a hyphen), or rasp[[ ]]berry which is clunky and less than totally clear? Code:
Sub RevsToUnderlineStrikethrough() ' ' Converts tracked revisions in selected text into underline/strikethrough format, ' and removes tracked revisions from the selected text. ' Dim chgRev As Word.Revision 'Declaring variable If Selection.Range.Revisions.Count = 0 Then 'Nothing to do, show error dialog MsgBox "Nothing selected or no revisions in selection.", vbOKOnly Else ActiveDocument.TrackRevisions = False 'Disable tracked revisions For Each chgRev In Selection.Range.Revisions 'Main function If chgRev.Type = wdRevisionDelete Then 'Strikethrough deletion and reject change If chgRev.Range.Characters.Count <= 5 Then 'Delete with brackets Dim rngRev As Range Set rngRev = chgRev.Range chgRev.Range.Font.StrikeThrough = False chgRev.Reject rngRev.InsertBefore ("[[") rngRev.InsertAfter ("]]") Else chgRev.Range.Font.StrikeThrough = True chgRev.Reject End If ElseIf chgRev.Type = wdRevisionInsert Then 'Underline addition and accept change chgRev.Range.Font.Underline = wdUnderlineSingle chgRev.Accept End If Next chgRev For Each strChar In Selection.Range.Characters 'insert spaces between striken and added text Set strNextChar = strChar.Next(wdCharacter, 1) If strChar.Text <> Chr(32) And Not (strNextChar Is Nothing) Then If strChar.Font.StrikeThrough = True And strNextChar.Font.Underline = wdUnderlineSingle Then strChar.InsertAfter (" ") ElseIf strChar.Font.Underline = wdUnderlineSingle And strNextChar.Font.StrikeThrough = True Then strChar.InsertAfter (" ") End If End If Next strChar Set strPrevChar = Nothing Set strNextChar = Nothing For Each strChar In Selection.Range.Characters 'Get rid of stray underlined and stricken-through spaces Set strPrevChar = strChar.Previous(wdCharacter, 1) Set strNextChar = strChar.Next(wdCharacter, 1) If strChar.Text = Chr(32) Then If strChar.Font.StrikeThrough = True Then 'Stricken-through space If strPrevChar.Font.StrikeThrough = False Then 'De-strikethrough leading stricken space strChar.Font.StrikeThrough = False End If If strNextChar.Font.StrikeThrough = False Then 'De-strikethrough trailing stricken space strChar.Font.StrikeThrough = False End If End If If strChar.Font.Underline = wdUnderlineSingle Then 'Underlined space If strPrevChar.Font.Underline = wdUnderlineNone Then 'De-underline leading underline spaces strChar.Font.Underline = wdUnderlineNone End If If strNextChar.Font.Underline = wdUnderlineNone Then 'De-underline trailing underline spaces strChar.Font.Underline = wdUnderlineNone End If End If End If Next strChar Set strPrevChar = Nothing Set strNextChar = Nothing With Selection.Range.Find 'Add/delete spaces around double brackets - this doesn't work perfectly yet either .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = True .Text = "([! ])\[\[" .Replacement.Text = "\1 [[" .Execute Replace:=wdReplaceAll .Text = "\]\]([0-9A-z])" .Replacement.Text = "]] \1" .Execute Replace:=wdReplaceAll .Text = "\[\[([ ]@)" .Replacement.Text = "[[" .Execute Replace:=wdReplaceAll .Text = "([ ]@)\]\]" .Replacement.Text = "]]" .Execute Replace:=wdReplaceAll ' Delete empty double bracket sets .Text = "\[\[\]\]" .Replacement.Text = "" .Execute Replace:=wdReplaceAll .MatchWildcards = False .Text = " [[" .Font.Underline = wdUnderlineSingle .Replacement.Text = " [[" .Replacement.Font.Underline = wdUnderlineNone .Execute Replace:=wdReplaceAll ' Delete duplicate spaces, unless after closing paren--can't get this to work, so using loop below ' .Text = "([! \)])([ ]@)" ' .Replacement.Text = "\1 " ' .Execute Replace:=wdReplaceAll End With For Each strChar In Selection.Range.Characters ' Delete duplicate spaces, unless after closing paren ' If rng.Start = 0 Then ' ElseIf rng.End = ActiveDocument.Range.End Then Set strPrevChar = strChar.Previous(wdCharacter, 1) Set strNextChar = strChar.Next(wdCharacter, 1) If strPrevChar Is Nothing Then If strChar.Text = Chr(32) Then ' The selection is the first character in the document If strNextChar Is Nothing Then ' The last character is a space; delete it strChar.Delete End If Do While strNextChar.Text = Chr(32) 'Delete any one or more spaces after this space strNextChar.Delete Set strNextChar = strChar.Next(wdCharacter, 1) Loop End If ElseIf strChar.Text = Chr(32) And strPrevChar <> ")" Then If strNextChar Is Nothing Then 'The last character is a space; delete it strChar.Delete End If Do While strNextChar.Text = Chr(32) 'Delete any one or more spaces after this space strNextChar.Delete Set strNextChar = strChar.Next(wdCharacter, 1) Loop End If Next strChar 'Set strPrevChar = Nothing 'Set strNextChar = Nothing End If End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro to list all character styles in a document | ljd108 | Word VBA | 8 | 10-06-2022 01:56 PM |
Replace a random character with the same character | RickLegrand | Word | 7 | 07-23-2015 06:35 PM |
How can select from a specific character to another character | mohsen.amiri | Word | 2 | 02-19-2015 11:38 PM |
Regular (roman) character style doesn't change text to roman | kcbenson | Word | 2 | 10-16-2014 01:31 PM |
Finding or searching ^ character in word document | shahin3121 | Word | 2 | 03-05-2012 06:16 PM |