Actually I believe it was Frosty's code, not mine.
Glad it worked for you though.
Printable View
Actually I believe it was Frosty's code, not mine.
Glad it worked for you though.
Actually it is Frosty's code.
Quote:
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.
Code: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
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...
Quote:
Originally Posted by gmaxey
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.