Actually I believe it was Frosty's code, not mine.
Glad it worked for you though.
Actually I believe it was Frosty's code, not mine.
Glad it worked for you though.
Actually it is Frosty's code.
Originally Posted by fumei
Yeah, your right, my bad again.
Tks a lot Jason[Frosty] for the code, it's wonderful.
but tks also Fumei for helping a lot too.
You two are fantastic.
Hi Guys
I'm using last posted Frosty's code since a few months now and it works great !!!
Thanks Frosty !
But I wanted a little bit more... I'd like the code to keep smallcaps too
I tried to add stuff with SmallCaps but it failed
It made uppercase words instead, and that's bad...
If someone has a great idea of the reason why and how to solve this problem, he would be welcome
Well here is my revised version which seems to work with the addition of ALLCAPS and SmallCaps. Note, despite the fact that I am using Word 2010, I couldn't get the UndoRecord to work so I am undoing multiple times.
Option Explicit '---------------------------------------------------------------------------------------------- ' Main routine -- works on the active document, and leaves you with a new document in which ' the main font formatting is restored. ' NOTE: if not used in Word 2010, you may need to do multiple "undo" actions to restore your ' document to the way it was -- so TEST a lot '---------------------------------------------------------------------------------------------- Sub ConversionWithFontFormatRestoration() Dim oOrigDoc As Document Dim oNewDoc As Document Dim rngOrigSelection As Range Dim lngUndo As Long Set oOrigDoc = ActiveDocument Set oNewDoc = Documents.Add '(Visible:=False) 'mark the formatting lngUndo = FontFormat_MarkAll(oOrigDoc) 'note, this can pull over section breaks, etc oOrigDoc.Content.Copy 'if we were able to use the undo record, undo the marks (comment out to see the process) #If VBA7 Then 'store the selection Set rngOrigSelection = Selection.Range.Duplicate 'undo (which selects the whole document_ oOrigDoc.Undo lngUndo 'restore the selection rngOrigSelection.Select #End If oNewDoc.Content.Paste ' .PasteSpecial dataType:=wdPasteFormattedText oNewDoc.Range.Font.Reset oNewDoc.Range.Style = "Normal" 'replace the formatting FontFormat_ReplaceAll oNewDoc 'make it visible oNewDoc.ActiveWindow.Visible = True End Sub '---------------------------------------------------------------------------------------------- ' Mark all font formats desired '---------------------------------------------------------------------------------------------- Function FontFormat_MarkAll(oDoc As Document) As Long Dim oFont As Font Dim lngUndo As Long ' 'make use of the undo record, if it's available ' #If VBA7 Then ' Application.UndoRecord.StartCustomRecord "Mark Font Formatting" ' #End If 'setting to new clears out all other settings, so you're only searching for a single item Set oFont = New Font oFont.Bold = True If FontFormat_Mark(oFont, "Bold", oDoc.Content) Then FontFormat_MarkAll = 1 Set oFont = New Font oFont.Italic = True If FontFormat_Mark(oFont, "Italic", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If Set oFont = New Font oFont.Underline = wdUnderlineSingle If FontFormat_Mark(oFont, "UnderlineSingle", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If Set oFont = New Font oFont.Superscript = True If FontFormat_Mark(oFont, "Superscript", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If Set oFont = New Font oFont.Subscript = True If FontFormat_Mark(oFont, "Subscript", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If Set oFont = New Font oFont.SmallCaps = True If FontFormat_Mark(oFont, "SmallCaps", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If Set oFont = New Font oFont.AllCaps = True If FontFormat_Mark(oFont, "AllCaps", oDoc.Content) Then FontFormat_MarkAll = FontFormat_MarkAll + 1 End If ' 'if we made use of it with the conditional compile, end it (this gives one undo, rather than a bunch) ' #If VBA7 Then ' Application.UndoRecord.EndCustomRecord ' #End If End Function '---------------------------------------------------------------------------------------------- ' mark an individual font format '---------------------------------------------------------------------------------------------- Function FontFormat_Mark(oFont As Font, sIdentifier As String, rngSearch As Range) As Boolean With rngSearch.Find 'just setting the font object doesn't work - so you'd have to do this for each item you care about With .Font .Bold = oFont.Bold .Italic = oFont.Italic .Underline = oFont.Underline .Superscript = oFont.Superscript .Subscript = oFont.Subscript .SmallCaps = oFont.SmallCaps .AllCaps = oFont.AllCaps End With .Replacement.Text = "<~" & sIdentifier & "~>^&</~" & sIdentifier & "~>" .Execute Replace:=wdReplaceAll If .Found Then FontFormat_Mark = True End With End Function '---------------------------------------------------------------------------------------------- ' Replace all font formats '---------------------------------------------------------------------------------------------- Sub FontFormat_ReplaceAll(oDoc As Document) Dim oFont As Font 'make use of the undo record, if it's available #If VBA7 Then Application.UndoRecord.StartCustomRecord "Replace Font Formatting" #End If 'setting to new clears out all other settings, so you're only searching for a single item Set oFont = New Font oFont.Bold = True FontFormat_Replace oFont, "Bold", oDoc.Content Set oFont = New Font oFont.Italic = True FontFormat_Replace oFont, "Italic", oDoc.Content ' Set oFont = New Font oFont.Underline = wdUnderlineSingle FontFormat_Replace oFont, "UnderlineSingle", oDoc.Content ' Set oFont = New Font oFont.Superscript = True FontFormat_Replace oFont, "Superscript", oDoc.Content Set oFont = New Font oFont.Subscript = True FontFormat_Replace oFont, "Subscript", oDoc.Content Set oFont = New Font oFont.AllCaps = True FontFormat_Replace oFont, "AllCaps", oDoc.Content Set oFont = New Font oFont.SmallCaps = True FontFormat_Replace oFont, "SmallCaps", oDoc.Content 'if we made use of it with the conditional compile, end it (this gives one undo, rather than a bunch) #If VBA7 Then Application.UndoRecord.EndCustomRecord #End If End Sub '---------------------------------------------------------------------------------------------- ' Replace an indivdual font format '---------------------------------------------------------------------------------------------- Sub FontFormat_Replace(oFont As Font, sIdentifier As String, rngSearch As Range) With rngSearch.Duplicate.Find 'have to use wild card searches .MatchWildcards = True 'use the slashes to identify the < as real < 'not wildcard search special characters .Text = "\<~" & sIdentifier & "~\>*\</~" & sIdentifier & "~\>" 'set up the formatting replacements With .Replacement.Font .Bold = oFont.Bold .Italic = oFont.Italic .Underline = oFont.Underline .Superscript = oFont.Superscript .Subscript = oFont.Subscript .SmallCaps = oFont.SmallCaps .AllCaps = oFont.AllCaps End With 'replace the formatting .Execute Replace:=wdReplaceAll 'remove the start and end markers by resetting the formatting .ClearFormatting .Replacement.ClearFormatting 'turning off wildcard searches .MatchWildcards = False 'and removing the specific text .Text = "<~" & sIdentifier & "~>" .Replacement.Text = "" .Execute Replace:=wdReplaceAll 'and the end codes .Text = "</~" & sIdentifier & "~>" .Execute Replace:=wdReplaceAll End With End Sub
Last edited by gmaxey; 07-11-2017 at 04:42 AM.
Well Greg thanks for your quick solution
Unfortunately, it seems to work on smallcaps i newly wrote, but not working on my test file (smallcaps are not recognized at all in a part of the text)
And I think i can't join my test file here....
then this will stay unsolved I fear...
Last edited by gmaxey; 07-11-2017 at 04:43 AM.
you may find my test file here : uptobox.com/40e98ot22z7f
I think that "smallcaps" from my test file are not true SmallCaps characters, they only look like small capitals, that's the reason why they are not recognized by your code Greg.it is supposed to do
Anyway, thanks for your work Greg : it does what it is supposed to do !
You're welcome. It is still Jason's (aka Frosty's) code just in my style.
Posting Permissions
