delete all styles but to keep the font, bold etc. format

[ayltonasc]

I'm trying to figure out how to change the code below posted by
Paul Edstein answering a similar thread, but I cannot put the link below, so I'll post the name of the thread:
'Unwanted style name aliases in Word'

The similar thread was related to deleting the aliases from the name of the styles finishing with 'char' ou '* char'

the point is, I want almost the same thing, but instead of deleting just styles having '* char' in the name, I want to delete all styles, except the hard/internal ones, and I want to keep the format (bold, italic, font name and size, etc).

what I already tried:
in the sub DeleteCharCharStylesKeepFormatting I deleted the conditionals 'if' and the loop: 'do while', so I could free the code deleted all the styles and not only those with 'char' in their names. ...the rest of the code inside the 'functions' I didn't change because I guess nothing needed to be done.

I believe it's goes to an infinity loop in the text: .Execute from the code:

Do
With rngResult.Find
.ClearFormatting
.Style = sty
.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With


below is the original code to delete the styles with the 'char' in their name, and in the end of the text I'll post the code that I changed, and of course, its not working.


Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
Do
bCharCharFound = False
For i = doc.Styles.Count To 1 Step -1
Set sty = doc.Styles(i)
sStyleName = sty.NameLocal
If sStyleName Like "* Char*" Then
bCharCharFound = True
If sty.Type = wdStyleTypeCharacter Then
Call StripStyleKeepFormatting(sty, doc)
On Error Resume Next
' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
sty.LinkStyle = wdStyleNormal
sty.Delete
Err.Clear
Else
sStyleReName = Replace(sStyleName, " Char", "")
On Error Resume Next
sty.NameLocal = sStyleReName
If Err.Number = 5173 Then
Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
sty.Delete
Err.Clear
Else
On Error GoTo ERR_HANDLER
End If
End If
Exit For
End If
Set sty = Nothing
Next i
Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & _
Err.Number & Chr(58) & Chr(32) & Err.Description, _
vbExclamation
End Sub

Function SwapStyles(ByRef styFind As Style, _
ByRef styReplace As Style, _
ByRef doc As Document)
With doc.Range.Find
.ClearFormatting
.Text = ""
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Style = styFind
.Replacement.ClearFormatting
.Replacement.Style = styReplace
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
End With
End Function

Function StripStyleKeepFormatting(ByRef sty As Style, ByRef doc As Document)
Dim rngToSearch As Range
Dim rngResult As Range
Dim f As Font
Set rngToSearch = doc.Range
Set rngResult = rngToSearch.Duplicate
Do
With rngResult.Find
.ClearFormatting
.Style = sty
.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If Not rngResult.Find.Found Then Exit Do
Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Font = f
.MoveStart wdWord
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found
End Function

modified code that I did something wrong below:


Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
'Do
'bCharCharFound = False
For i = doc.Styles.Count To 1 Step -1
Set sty = doc.Styles(i)
sStyleName = sty.NameLocal
'If sStyleName Like "* Char*" Then
'bCharCharFound = True
'If sty.Type = wdStyleTypeCharacter Then
Call StripStyleKeepFormatting(sty, doc)
On Error Resume Next
' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
'sty.LinkStyle = wdStyleNormal(commented out because i'm using word 2000)
sty.Delete
Err.Clear
'Else
'sStyleReName = Replace(sStyleName, " Char", "")
'On Error Resume Next
'sty.NameLocal = sStyleReName
'If Err.Number = 5173 Then
'Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
' sty.Delete
'Err.Clear
'Else
'On Error GoTo ERR_HANDLER
'End If
'End If
'Exit For
'End If
Set sty = Nothing
'Next I
' Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & Err.Number & Chr(58) & Chr(32) & Err.Description, _
vbExclamation
End Sub

[fumei]

Please use the VBA code tags. It makes code easier to read. In particular you code as is make it very hard to see what is happening, with all the commented out lines.

Can you say why you want to do this? It is very unusual.

[ayltonasc]

Please use the VBA code tags. It makes code easier to read. In particular you code as is make it very hard to see what is happening, with all the commented out lines.

Can you say why you want to do this? It is very unusual.


I'm sorry, I'm really new in foruns and got no idea how to do that! can u please explain to me or send me the link to the page that explains how to?
I'm sorry, I'm not lazy, just lost in here. ...I'll get better with time.

[ayltonasc]

I'm trying to figure out how to change the code below posted by
Paul Edstein answering a similar thread, but I cannot put the link below, so I'll post the name of the thread:
'Unwanted style name aliases in Word'

The similar thread was related to deleting the aliases from the name of the styles finishing with 'char' ou '* char'

the point is, I want almost the same thing, but instead of deleting just styles having '* char' in the name, I want to delete all styles, except the hard/internal ones, and I want to keep the format (bold, italic, font name and size, etc).

what I already tried:
in the sub DeleteCharCharStylesKeepFormatting I deleted the conditionals 'if' and the loop: 'do while', so I could free the code deleted all the styles and not only those with 'char' in their names. ...the rest of the code inside the 'functions' I didn't change because I guess nothing needed to be done.

I believe it's goes to an infinity loop in the text: .Execute from the code:

Do
With rngResult.Find
.ClearFormatting
.Style = sty
.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With

below is the original code to delete the styles with the 'char' in their name, and in the end of the text I'll post the code that I changed, and of course, its not working.



Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
Do
bCharCharFound = False
For i = doc.Styles.Count To 1 Step -1
Set sty = doc.Styles(i)
sStyleName = sty.NameLocal
If sStyleName Like "* Char*" Then
bCharCharFound = True
If sty.Type = wdStyleTypeCharacter Then
Call StripStyleKeepFormatting(sty, doc)
On Error Resume Next
' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
sty.LinkStyle = wdStyleNormal
sty.Delete
Err.Clear
Else
sStyleReName = Replace(sStyleName, " Char", "")
On Error Resume Next
sty.NameLocal = sStyleReName
If Err.Number = 5173 Then
Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
sty.Delete
Err.Clear
Else
On Error GoTo ERR_HANDLER
End If
End If
Exit For
End If
Set sty = Nothing
Next i
Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & _
Err.Number & Chr(58) & Chr(32) & Err.Description, _
vbExclamation
End Sub

Function SwapStyles(ByRef styFind As Style, _
ByRef styReplace As Style, _
ByRef doc As Document)
With doc.Range.Find
.ClearFormatting
.Text = ""
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Style = styFind
.Replacement.ClearFormatting
.Replacement.Style = styReplace
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
End With
End Function


Function StripStyleKeepFormatting(ByRef sty As Style, _
ByRef doc As Document)
Dim rngToSearch As Range
Dim rngResult As Range
Dim f As Font
Set rngToSearch = doc.Range
Set rngResult = rngToSearch.Duplicate
Do
With rngResult.Find
.ClearFormatting
.Style = sty
.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If Not rngResult.Find.Found Then Exit Do
Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Font = f
.MoveStart wdWord
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found
End Function


modified code that I did something wrong below:


Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
'Do
'bCharCharFound = False
For i = doc.Styles.Count To 1 Step -1
Set sty = doc.Styles(i)
sStyleName = sty.NameLocal
'If sStyleName Like "* Char*" Then
'bCharCharFound = True
'If sty.Type = wdStyleTypeCharacter Then
Call StripStyleKeepFormatting(sty, doc)
On Error Resume Next
' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
'sty.LinkStyle = wdStyleNormal(commented out because i'm using word 2000)
sty.Delete
Err.Clear
'Else
'sStyleReName = Replace(sStyleName, " Char", "")
'On Error Resume Next
'sty.NameLocal = sStyleReName
'If Err.Number = 5173 Then
'Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
' sty.Delete
'Err.Clear
'Else
'On Error GoTo ERR_HANDLER
'End If
'End If
'Exit For
'End If
Set sty = Nothing
'Next i
' Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & Err.Number & Chr(58) & Chr(32) & Err.Description, vbExclamation
End Sub

[Frosty]

Remove the comment from the "Next i" line
Remove the comment from the "On Error GoTo ERR_HANDLER" line

That's what keeps you looping through all the styles and resets your error handler.

You'll definitely want to test this code on different documents, as it can potentially cause issues with loss of direct formatting, character styles on top of paragraph styles, etc.

But in general, it's going to work for you. You didn't post the StripStyleKeepFormatting function, but that should also stay as it was, I believe.

[ayltonasc]

Remove the comment from the "Next i" line
Remove the comment from the "On Error GoTo ERR_HANDLER" line

That's what keeps you looping through all the styles and resets your error handler.

You'll definitely want to test this code on different documents, as it can potentially cause issues with loss of direct formatting, character styles on top of paragraph styles, etc.

But in general, it's going to work for you. You didn't post the StripStyleKeepFormatting function, but that should also stay as it was, I believe.

Hi my friend Frosty, the code didn't work, but I appreciated your help. I'D also like to say that I wasn't cross-posting once the address provided is not a thread created by myself. Actually it's just a similar one that I found created for somebody else. I just thought it would be helpfull as a sample. The etiquette u provided me tells it is not good s person whom opens lots of threads to try to get a faster answer, so it did not applies to me for the reason above. Now, I really could provided the address between URL URL code, I just didint because I use to copy and past at my office because the server blocks links.

Regards

[fumei]

Hi. Frosty was not pointing anything at you. The reference to cross-posting is part of his standard signature.

[ayltonasc]

Hi. Frosty was not pointing anything at you. The reference to cross-posting is part of his standard signature.


Hi fumei, tks. got you! ...you know, I'm a newbie, lol

[Frosty]

Yes, what Fumei said -- that was just a standard disclaimer.

Taking out all of the commented lines of code (apart from the two I think you needed to put back in), your routine should look something like this. When you say it doesn't work -- can you be a little more specific? What didn't work? The code as you originally posted wouldn't have even run-- it would have given you a compile error. At this point, it should at least compile when you first go to run the macro...



Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
For i = doc.Styles.Count To 1 Step -1
Set sty = doc.Styles(i)
sStyleName = sty.NameLocal
Call StripStyleKeepFormatting(sty, doc)
On Error Resume Next
sty.Delete
Err.Clear
On Error GoTo ERR_HANDLER
Set sty = Nothing
Next i
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & _
Err.Number & Chr(58) & Chr(32) & Err.Description, _
vbExclamation
End Sub

[ayltonasc]

Yes Frosty, thank your for helping
after that thing with the commas, the next problem emerged
seems to be in an infinite loop
I'm stopping the macro after 1 minute running and no result, pressing ctrl + pause break, and when the macro stops, it highlights the line possibly problematic, and it its the line '.execute' inside the block 'With rngResult.Find'.

I'm gonna put the piece of block and write a comment (STOPS IN THIS LINE) to make it more clear


Function StripStyleKeepFormatting(ByRef sty As Style, _
ByRef doc As Document)
Dim rngToSearch As Range
Dim rngResult As Range
Dim f As Font
Set rngToSearch = doc.Range
Set rngResult = rngToSearch.Duplicate
Do
With rngResult.Find
.ClearFormatting
.Style = sty
.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute 'STOPS IN THIS LINE
End With
If Not rngResult.Find.Found Then Exit Do
Set f = rngResult.Font.Duplicate
With rngResult
.Font.Reset
.Font = f
.MoveStart wdWord
.End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found
End Function

[Frosty]

And now you get into real troubleshooting.

If your code stops on the Execute line -- you're going to need to find out why. What is the style it is trying to search for? Is that style applied anywhere in the document?

And we may need to back up a bit and have you answer an earlier question: why do you want to do this in the first place?

I guarantee you the problem at this point is not a coding problem, but rather something particular about your setup and the documents you are running on (for example, the original code would *only* run this formatting on Character styles -- since you are now running it on "all" styles - including table styles, list styles and paragraph styles -- you may need to have it adjust further).

Since I'm not going to throw code at you to see what may or may not work -- you'll need to define why exactly you want to do this.

And you may want to go do some learning on your own about styles... do you really want to, essentially, take out all formatting in the document *except* for font formatting? Why?

And if that's what you want to do -- what font formatting do you actually care about retaining? Is it just bold/italic/underline? Superscript? Because it may behoove you to go about this in an entirely different way...

[ayltonasc]

Frosty, thanks again

Let me try clarify it:
My job at the company that I work for, it's to format lots of converted documents daily. These docs are usually converted from scanned pdf to word, and then, they are delivered for translation, but the translator doesn't even care about formatting, instead, they focus on the translation itself.
After they fineshed their job, they send the files to me so I format it properly.

The problem is: the conversion messes all the format, for exemple, the paragraphs left and righ idents has small different values throughout the doc, like 1st paragraph having -0,16pt left, and -0,23 right indent., 2nd paragraph -0,03 left, and -0,07 righ, and so on...
The before and after paragraphs same thing, like: spaceafter having the value 2.37pt, the next paragraph 2.89 pt, and so on.

and the document has lots of unwanted created styles, and most of them were used, but they are not necessary, what I really wanted is just the bold, itálic, superscript/subscript, underline and to keep just the hard/internal styles.

If I delete the styles and characteres styles, sometimes I lost the bold, italic, superscript/subscript, underline information, and it takes too long to compare the two version of the docs, to find which words should I put the format back on (bold, italic, etc.)

The part of the paragraph indent I gave up, I was trying to indent to the 0 value, both right and left indention, but if the paragraphs had an messed up FirstLineIndent, like some paragraphs -0,83, others -0,93, etc... I wanted to format all of them to -0,75, so the paragraphs who had the FirstLineIndent, would have the values: .LeftIndent = CentimetersToPoints(0.75); .FirstLineIndent = CentimetersToPoints(-0.75); and RighIndent = CentimetersToPoints(0.00)

I know that to put zero value for the left and right indent it's really easy, actually we dont even need a macro for that, ...the difficult part is to check whether it has or not messed FirstLineIndent and then fix it, so I decided to keep doing it mannually.

Now I was trying to fix the styles and format of the characteres.

If you have any idea what else should I do, I'll really appreciate.
tks for the effort and patience

Regards.
Ailton

[fumei]

Oh boy.

[ayltonasc]

Fumei, did I say something wrong?

[Frosty]

Fumei is just reacting to what a big topic this is -- you're talking about document conversion, which is an entirely different topic really than document cleanup.

Your approach is to take the converted document (however you've received it) and "cleaning up" some stuff so that it is okay to use for the end-user. That clean up involves getting rid of some paragraph formatting, "bad" styles, but still trying to preserve some document formatting.

For document conversion, I actually advocate the reverse -- using a "Paste Special Unformatted Text" approach into a "clean new document" shell, and then making sure to restore the stuff that you want to keep (which, in this case, is *some* font formatting)

I have some massively complicated code which addresses this in a much more robust fashion. But for a couple of reasons (not the least of which is what I'm guessing is your level of expertise in VBA programming), I'm giving you a more simple approach to this. I've included the storing and restoring of the following font attributes: Bold, Italic, *single* underline, superscript and subscript (beware of these two, as often scanned documents will show text as superscript and subscript when it's really just the scan being slightly out of alignment.

This may help you on your way... although it is still pretty complex code for a beginner.



' 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
Set oOrigDoc = ActiveDocument
Set oNewDoc = Documents.Add(Visible:=False)
'mark the formatting
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
'restore the selection
rngOrigSelection.Select
#End If
oNewDoc.Content.PasteSpecial dataType:=wdPasteText
'replace the formatting
FontFormat_ReplaceAll oNewDoc
'make it visible
oNewDoc.ActiveWindow.Visible = True
End Sub

' Mark all font formats desired


Sub FontFormat_MarkAll(oDoc As Document)
Dim oFont As Font
'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
FontFormat_Mark oFont, "Bold", oDoc.Content
Set oFont = New Font
oFont.Italic = True
FontFormat_Mark oFont, "Italic", oDoc.Content
Set oFont = New Font
oFont.Underline = wdUnderlineSingle
FontFormat_Mark oFont, "UnderlineSingle", oDoc.Content
Set oFont = New Font
oFont.Superscript = True
FontFormat_Mark oFont, "Superscript", oDoc.Content
Set oFont = New Font
oFont.Subscript = True
FontFormat_Mark oFont, "Subscript", 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

' mark an individual font format


Sub FontFormat_Mark(oFont As Font, sIdentifier As String, rngSearch As Range)
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
End With
.Replacement.text = "[StartMy" & sIdentifier & "]^&[EndMy" & sIdentifier & "]"
.Execute Replace:=wdReplaceAll
End With
End Sub

' 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
'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 brackets as real brackets
'not wildcard search special characters
.text = "\[StartMy" & sIdentifier & "\]*\[EndMy" & sIdentifier & "\]"
'set up the formatting replacements
With .Replacement.Font
.Bold = oFont.Bold
.Italic = oFont.Italic
.Underline = oFont.Underline
.Superscript = oFont.Superscript
.Subscript = oFont.Subscript
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 = "[StartMy" & sIdentifier & "]"
.Replacement.text = ""
.Execute Replace:=wdReplaceAll
'and the end codes
.text = "[EndMy" & sIdentifier & "]"
.Execute Replace:=wdReplaceAll
End With
End Sub

[Frosty]

And, by the way, this can get as complex and robust as you want it to as you add more format characteristics you want to retain (like some paragraph indents but not all, etc).

The things to watch out for are the following:

1. Your format "indicators" (I've used "[StartMyBold]" and "[EndMyBold]" -- in my "real" code which does this, I use very long text strings which are never likely to be in a document, with case-sensitive searching, so that I don't get any false positives when find/replacing formatting -- so my "start format" characters look something like "**[StArTxYzzY1253c235BOLD241824xyYXYasd23]**"

2. The code creates a new document -- which will be based on your Normal template. If your Normal template has a bunch of custom styles in it... then you're going to get those custom styles in every document created by this process. So you can either create a new document on a different template (something specific to the document shell you want these resultant documents to start from), or you're going to need to make that part of the code more robust, or you're going to need to delete your normal template to get a "clean" one.

3. Wildcard searching -- because of the need to use Wildcard searching in the format replacement area, I have to use special characters in a wildcard search which don't need to exist in the original search. Be careful making modifications to these find and replace strings without reading up on proper wildcard searches. It will help a lot to just try doing regular wildcard searches (not replacing anything) to see what the text actually needs to be.

I'm on vacation soon, so if I don't respond again for some time... hopefully someone else can pick up the torch.

- Frosty aka Jason

[ayltonasc]

JAson, tks a lot, i'm gonna try to understand the code and I'll give you a feedback soon. Have a good vacation.
Regards.
Ailton

[fumei]

Frosty (Jason) knows me too well. I was indeed reacting to the massiveness of the topic.

As you can see from Jason's sample code, this can be a VERY complex operation. There are so many variables to deal with.

BTW, I agree with Jason regarding document conversion. The amount of work involved in order to retain SOME format is simply not worth it. I bring in content unformatted and apply the formats I want. Virtually all formats that I need I have as keyboard shortcuts. So it is WAY faster for me to apply formats than to "fix" formats.

Good luck. I look forward to seeing what you come up with.

[ayltonasc]

yes Fumei, thank you.
I'm not a native English speaker, so sometimes I don't understand the English in first place. So you can imagine how things are more difficult for my understanding.

I really appreciated your words, and I'd like to say, that is visible you guys are experts. I'm just a learner

Now one thing that I cannot understand is: how you guys can consider to be faster, to manually put bold, italic and underline itens back on thousands of pages everyday.

Especifically on my case (working with two monitor), I have to look to both monitors, where the original document is located in one of them, inspect it searching for bold, italic, underline itens, then go to the other monitor and, for instance, put the bold format exactly in the same word, which is not located in the same page position as the original document, because remember, in one hand, we have a not formatted document, and in the other hand, a document full of format information, like space and after paragraphs, different font sizes, and so on, etc... Add to it, a foreing language, maybe German or Chinese, now try to memorize a bold Chinese word in the original document, and quickly go to the other monitor, to scroll the document searching for the same word until you find it, then finally applies the format.

About shortcuts, I already use lots, really lots of them.

[ayltonasc]

Now, if you guys are trying to say that this duplicate doc method, extracting just the bold, italic, and underline format from the first document, and then to reformat just the rest of other format information it's easier, I agree, cause it's exactly what I was looking for (a doc with bold, italic, and underline, superscript, etc... information) and the rest I reformat with no problems at all

BTW, Tks a lot Fumei, I've just tried the macro you've created and it's works like a charm!!!
I thought it would take days to make it usefull, but for my suprise, it worked since the first try.

FINALLY SOLVED
Tks for the patience, Jason and Fumei

[fumei]

Actually I believe it was Frosty's code, not mine.

Glad it worked for you though.

[fumei]

Actually it is Frosty's code.

[ayltonasc]

Actually it is Frosty's code.


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.

[iwonder]

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 :)

[gmaxey]

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

[iwonder]

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...


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

[iwonder]

you may find my test file here : uptobox.com/40e98ot22z7f

[iwonder]

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 ! :)

[gmaxey]

You're welcome. It is still Jason's (aka Frosty's) code just in my style.